summaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/s-addima.adb76
-rw-r--r--gcc/ada/s-addima.ads43
-rw-r--r--gcc/ada/s-arit64.adb719
-rw-r--r--gcc/ada/s-arit64.ads84
-rw-r--r--gcc/ada/s-assert.adb49
-rw-r--r--gcc/ada/s-assert.ads45
-rw-r--r--gcc/ada/s-asthan.adb75
-rw-r--r--gcc/ada/s-asthan.ads63
-rw-r--r--gcc/ada/s-atacco.adb63
-rw-r--r--gcc/ada/s-atacco.ads33
-rw-r--r--gcc/ada/s-auxdec.adb709
-rw-r--r--gcc/ada/s-auxdec.ads556
-rw-r--r--gcc/ada/s-bitops.adb223
-rw-r--r--gcc/ada/s-bitops.ads101
-rw-r--r--gcc/ada/s-chepoo.ads76
-rw-r--r--gcc/ada/s-direio.adb377
-rw-r--r--gcc/ada/s-direio.ads130
-rw-r--r--gcc/ada/s-errrep.adb71
-rw-r--r--gcc/ada/s-errrep.ads48
-rw-r--r--gcc/ada/s-except.ads205
-rw-r--r--gcc/ada/s-exctab.adb192
-rw-r--r--gcc/ada/s-exctab.ads51
-rw-r--r--gcc/ada/s-exnflt.ads46
-rw-r--r--gcc/ada/s-exngen.adb154
-rw-r--r--gcc/ada/s-exngen.ads66
-rw-r--r--gcc/ada/s-exnint.ads46
-rw-r--r--gcc/ada/s-exnlfl.ads46
-rw-r--r--gcc/ada/s-exnlin.ads46
-rw-r--r--gcc/ada/s-exnllf.ads46
-rw-r--r--gcc/ada/s-exnlli.ads46
-rw-r--r--gcc/ada/s-exnsfl.ads46
-rw-r--r--gcc/ada/s-exnsin.ads46
-rw-r--r--gcc/ada/s-exnssi.ads46
-rw-r--r--gcc/ada/s-expflt.ads45
-rw-r--r--gcc/ada/s-expgen.adb183
-rw-r--r--gcc/ada/s-expgen.ads66
-rw-r--r--gcc/ada/s-expint.ads45
-rw-r--r--gcc/ada/s-explfl.ads46
-rw-r--r--gcc/ada/s-explin.ads46
-rw-r--r--gcc/ada/s-expllf.ads46
-rw-r--r--gcc/ada/s-explli.ads46
-rw-r--r--gcc/ada/s-expllu.adb78
-rw-r--r--gcc/ada/s-expllu.ads51
-rw-r--r--gcc/ada/s-expmod.adb91
-rw-r--r--gcc/ada/s-expmod.ads49
-rw-r--r--gcc/ada/s-expsfl.ads46
-rw-r--r--gcc/ada/s-expsin.ads46
-rw-r--r--gcc/ada/s-expssi.ads46
-rw-r--r--gcc/ada/s-expuns.adb77
-rw-r--r--gcc/ada/s-expuns.ads51
-rw-r--r--gcc/ada/s-fatflt.ads51
-rw-r--r--gcc/ada/s-fatgen.adb836
-rw-r--r--gcc/ada/s-fatgen.ads101
-rw-r--r--gcc/ada/s-fatlfl.ads51
-rw-r--r--gcc/ada/s-fatllf.ads51
-rw-r--r--gcc/ada/s-fatsfl.ads51
-rw-r--r--gcc/ada/s-ficobl.ads160
-rw-r--r--gcc/ada/s-fileio.adb1041
-rw-r--r--gcc/ada/s-fileio.ads258
-rw-r--r--gcc/ada/s-finimp.adb582
-rw-r--r--gcc/ada/s-finimp.ads151
-rw-r--r--gcc/ada/s-finroo.adb99
-rw-r--r--gcc/ada/s-finroo.ads62
-rw-r--r--gcc/ada/s-fore.adb60
-rw-r--r--gcc/ada/s-fore.ads45
-rw-r--r--gcc/ada/s-gloloc.adb162
-rw-r--r--gcc/ada/s-gloloc.ads69
-rw-r--r--gcc/ada/s-imgbiu.adb158
-rw-r--r--gcc/ada/s-imgbiu.ads76
-rw-r--r--gcc/ada/s-imgboo.adb51
-rw-r--r--gcc/ada/s-imgboo.ads44
-rw-r--r--gcc/ada/s-imgcha.adb171
-rw-r--r--gcc/ada/s-imgcha.ads45
-rw-r--r--gcc/ada/s-imgdec.adb359
-rw-r--r--gcc/ada/s-imgdec.ads83
-rw-r--r--gcc/ada/s-imgenu.adb130
-rw-r--r--gcc/ada/s-imgenu.ads78
-rw-r--r--gcc/ada/s-imgint.adb98
-rw-r--r--gcc/ada/s-imgint.ads57
-rw-r--r--gcc/ada/s-imgllb.adb161
-rw-r--r--gcc/ada/s-imgllb.ads76
-rw-r--r--gcc/ada/s-imglld.adb89
-rw-r--r--gcc/ada/s-imglld.ads67
-rw-r--r--gcc/ada/s-imglli.adb99
-rw-r--r--gcc/ada/s-imglli.ads57
-rw-r--r--gcc/ada/s-imgllu.adb90
-rw-r--r--gcc/ada/s-imgllu.ads61
-rw-r--r--gcc/ada/s-imgllw.adb140
-rw-r--r--gcc/ada/s-imgllw.ads73
-rw-r--r--gcc/ada/s-imgrea.adb674
-rw-r--r--gcc/ada/s-imgrea.ads73
-rw-r--r--gcc/ada/s-imguns.adb90
-rw-r--r--gcc/ada/s-imguns.ads61
-rw-r--r--gcc/ada/s-imgwch.adb87
-rw-r--r--gcc/ada/s-imgwch.ads53
-rw-r--r--gcc/ada/s-imgwiu.adb138
-rw-r--r--gcc/ada/s-imgwiu.ads73
-rw-r--r--gcc/ada/s-inmaop.ads122
-rw-r--r--gcc/ada/s-interr.adb1572
-rw-r--r--gcc/ada/s-interr.ads281
-rw-r--r--gcc/ada/s-intman.ads128
-rw-r--r--gcc/ada/s-io.adb88
-rw-r--r--gcc/ada/s-io.ads53
-rw-r--r--gcc/ada/s-maccod.ads134
-rw-r--r--gcc/ada/s-mantis.adb57
-rw-r--r--gcc/ada/s-mantis.ads46
-rw-r--r--gcc/ada/s-mastop.adb130
-rw-r--r--gcc/ada/s-mastop.ads165
-rw-r--r--gcc/ada/s-memory.adb142
-rw-r--r--gcc/ada/s-memory.ads72
-rw-r--r--gcc/ada/s-osprim.ads86
-rw-r--r--gcc/ada/s-pack03.adb118
-rw-r--r--gcc/ada/s-pack03.ads54
-rw-r--r--gcc/ada/s-pack05.adb118
-rw-r--r--gcc/ada/s-pack05.ads54
-rw-r--r--gcc/ada/s-pack06.adb171
-rw-r--r--gcc/ada/s-pack06.ads64
-rw-r--r--gcc/ada/s-pack07.adb118
-rw-r--r--gcc/ada/s-pack07.ads54
-rw-r--r--gcc/ada/s-pack09.adb118
-rw-r--r--gcc/ada/s-pack09.ads54
-rw-r--r--gcc/ada/s-pack10.adb171
-rw-r--r--gcc/ada/s-pack10.ads64
-rw-r--r--gcc/ada/s-pack11.adb118
-rw-r--r--gcc/ada/s-pack11.ads54
-rw-r--r--gcc/ada/s-pack12.adb171
-rw-r--r--gcc/ada/s-pack12.ads64
-rw-r--r--gcc/ada/s-pack13.adb118
-rw-r--r--gcc/ada/s-pack13.ads54
-rw-r--r--gcc/ada/s-pack14.adb171
-rw-r--r--gcc/ada/s-pack14.ads64
-rw-r--r--gcc/ada/s-pack15.adb118
-rw-r--r--gcc/ada/s-pack15.ads54
-rw-r--r--gcc/ada/s-pack17.adb118
-rw-r--r--gcc/ada/s-pack17.ads54
-rw-r--r--gcc/ada/s-pack18.adb171
-rw-r--r--gcc/ada/s-pack18.ads64
-rw-r--r--gcc/ada/s-pack19.adb118
-rw-r--r--gcc/ada/s-pack19.ads54
-rw-r--r--gcc/ada/s-pack20.adb171
-rw-r--r--gcc/ada/s-pack20.ads64
-rw-r--r--gcc/ada/s-pack21.adb118
-rw-r--r--gcc/ada/s-pack21.ads54
-rw-r--r--gcc/ada/s-pack22.adb171
-rw-r--r--gcc/ada/s-pack22.ads64
-rw-r--r--gcc/ada/s-pack23.adb118
-rw-r--r--gcc/ada/s-pack23.ads54
-rw-r--r--gcc/ada/s-pack24.adb171
-rw-r--r--gcc/ada/s-pack24.ads64
-rw-r--r--gcc/ada/s-pack25.adb118
-rw-r--r--gcc/ada/s-pack25.ads54
-rw-r--r--gcc/ada/s-pack26.adb171
-rw-r--r--gcc/ada/s-pack26.ads64
-rw-r--r--gcc/ada/s-pack27.adb118
-rw-r--r--gcc/ada/s-pack27.ads54
-rw-r--r--gcc/ada/s-pack28.adb171
-rw-r--r--gcc/ada/s-pack28.ads64
-rw-r--r--gcc/ada/s-pack29.adb118
-rw-r--r--gcc/ada/s-pack29.ads54
-rw-r--r--gcc/ada/s-pack30.adb171
-rw-r--r--gcc/ada/s-pack30.ads64
-rw-r--r--gcc/ada/s-pack31.adb118
-rw-r--r--gcc/ada/s-pack31.ads54
-rw-r--r--gcc/ada/s-pack33.adb118
-rw-r--r--gcc/ada/s-pack33.ads54
-rw-r--r--gcc/ada/s-pack34.adb171
-rw-r--r--gcc/ada/s-pack34.ads64
-rw-r--r--gcc/ada/s-pack35.adb118
-rw-r--r--gcc/ada/s-pack35.ads54
-rw-r--r--gcc/ada/s-pack36.adb171
-rw-r--r--gcc/ada/s-pack36.ads64
-rw-r--r--gcc/ada/s-pack37.adb118
-rw-r--r--gcc/ada/s-pack37.ads54
-rw-r--r--gcc/ada/s-pack38.adb171
-rw-r--r--gcc/ada/s-pack38.ads64
-rw-r--r--gcc/ada/s-pack39.adb118
-rw-r--r--gcc/ada/s-pack39.ads54
-rw-r--r--gcc/ada/s-pack40.adb171
-rw-r--r--gcc/ada/s-pack40.ads64
-rw-r--r--gcc/ada/s-pack41.adb118
-rw-r--r--gcc/ada/s-pack41.ads54
-rw-r--r--gcc/ada/s-pack42.adb171
-rw-r--r--gcc/ada/s-pack42.ads64
-rw-r--r--gcc/ada/s-pack43.adb118
-rw-r--r--gcc/ada/s-pack43.ads54
-rw-r--r--gcc/ada/s-pack44.adb171
-rw-r--r--gcc/ada/s-pack44.ads64
-rw-r--r--gcc/ada/s-pack45.adb118
-rw-r--r--gcc/ada/s-pack45.ads54
-rw-r--r--gcc/ada/s-pack46.adb171
-rw-r--r--gcc/ada/s-pack46.ads64
-rw-r--r--gcc/ada/s-pack47.adb118
-rw-r--r--gcc/ada/s-pack47.ads54
-rw-r--r--gcc/ada/s-pack48.adb171
-rw-r--r--gcc/ada/s-pack48.ads64
-rw-r--r--gcc/ada/s-pack49.adb118
-rw-r--r--gcc/ada/s-pack49.ads54
-rw-r--r--gcc/ada/s-pack50.adb171
-rw-r--r--gcc/ada/s-pack50.ads64
-rw-r--r--gcc/ada/s-pack51.adb118
-rw-r--r--gcc/ada/s-pack51.ads54
-rw-r--r--gcc/ada/s-pack52.adb171
-rw-r--r--gcc/ada/s-pack52.ads64
-rw-r--r--gcc/ada/s-pack53.adb118
-rw-r--r--gcc/ada/s-pack53.ads54
-rw-r--r--gcc/ada/s-pack54.adb171
-rw-r--r--gcc/ada/s-pack54.ads64
-rw-r--r--gcc/ada/s-pack55.adb118
-rw-r--r--gcc/ada/s-pack55.ads54
-rw-r--r--gcc/ada/s-pack56.adb171
-rw-r--r--gcc/ada/s-pack56.ads64
-rw-r--r--gcc/ada/s-pack57.adb118
-rw-r--r--gcc/ada/s-pack57.ads54
-rw-r--r--gcc/ada/s-pack58.adb171
-rw-r--r--gcc/ada/s-pack58.ads64
-rw-r--r--gcc/ada/s-pack59.adb118
-rw-r--r--gcc/ada/s-pack59.ads54
-rw-r--r--gcc/ada/s-pack60.adb171
-rw-r--r--gcc/ada/s-pack60.ads64
-rw-r--r--gcc/ada/s-pack61.adb118
-rw-r--r--gcc/ada/s-pack61.ads54
-rw-r--r--gcc/ada/s-pack62.adb171
-rw-r--r--gcc/ada/s-pack62.ads64
-rw-r--r--gcc/ada/s-pack63.adb118
-rw-r--r--gcc/ada/s-pack63.ads54
-rw-r--r--gcc/ada/s-parame.adb73
-rw-r--r--gcc/ada/s-parame.ads136
-rw-r--r--gcc/ada/s-parint.adb303
-rw-r--r--gcc/ada/s-parint.ads145
-rw-r--r--gcc/ada/s-pooglo.adb98
-rw-r--r--gcc/ada/s-pooglo.ads77
-rw-r--r--gcc/ada/s-pooloc.adb154
-rw-r--r--gcc/ada/s-pooloc.ads79
-rw-r--r--gcc/ada/s-poosiz.adb359
-rw-r--r--gcc/ada/s-poosiz.ads88
-rw-r--r--gcc/ada/s-powtab.ads74
-rw-r--r--gcc/ada/s-proinf.adb45
-rw-r--r--gcc/ada/s-proinf.ads47
-rw-r--r--gcc/ada/s-rpc.adb126
-rw-r--r--gcc/ada/s-rpc.ads98
-rw-r--r--gcc/ada/s-scaval.ads75
-rw-r--r--gcc/ada/s-secsta.adb376
-rw-r--r--gcc/ada/s-secsta.ads102
-rw-r--r--gcc/ada/s-sequio.adb160
-rw-r--r--gcc/ada/s-sequio.ads83
-rw-r--r--gcc/ada/s-shasto.adb507
-rw-r--r--gcc/ada/s-shasto.ads220
-rw-r--r--gcc/ada/s-soflin.adb368
-rw-r--r--gcc/ada/s-soflin.ads365
-rw-r--r--gcc/ada/s-sopco3.adb62
-rw-r--r--gcc/ada/s-sopco3.ads44
-rw-r--r--gcc/ada/s-sopco4.adb64
-rw-r--r--gcc/ada/s-sopco4.ads44
-rw-r--r--gcc/ada/s-sopco5.adb66
-rw-r--r--gcc/ada/s-sopco5.ads44
-rw-r--r--gcc/ada/s-stache.adb282
-rw-r--r--gcc/ada/s-stache.ads107
-rw-r--r--gcc/ada/s-stalib.adb90
-rw-r--r--gcc/ada/s-stalib.ads250
-rw-r--r--gcc/ada/s-stoele.adb88
-rw-r--r--gcc/ada/s-stoele.ads91
-rw-r--r--gcc/ada/s-stopoo.ads71
-rw-r--r--gcc/ada/s-stratt.adb674
-rw-r--r--gcc/ada/s-stratt.ads194
-rw-r--r--gcc/ada/s-strops.adb149
-rw-r--r--gcc/ada/s-strops.ads64
-rw-r--r--gcc/ada/s-taasde.adb384
-rw-r--r--gcc/ada/s-taasde.ads154
-rw-r--r--gcc/ada/s-tadeca.adb58
-rw-r--r--gcc/ada/s-tadeca.ads46
-rw-r--r--gcc/ada/s-tadert.adb59
-rw-r--r--gcc/ada/s-tadert.ads46
-rw-r--r--gcc/ada/s-taenca.adb713
-rw-r--r--gcc/ada/s-taenca.ads95
-rw-r--r--gcc/ada/s-taprob.adb127
-rw-r--r--gcc/ada/s-taprob.ads225
-rw-r--r--gcc/ada/s-taprop.ads476
-rw-r--r--gcc/ada/s-tarest.adb548
-rw-r--r--gcc/ada/s-tarest.ads211
-rw-r--r--gcc/ada/s-tasdeb.adb704
-rw-r--r--gcc/ada/s-tasdeb.ads179
-rw-r--r--gcc/ada/s-tasinf.adb46
-rw-r--r--gcc/ada/s-tasinf.ads101
-rw-r--r--gcc/ada/s-tasini.adb981
-rw-r--r--gcc/ada/s-tasini.ads220
-rw-r--r--gcc/ada/s-taskin.adb181
-rw-r--r--gcc/ada/s-taskin.ads983
-rw-r--r--gcc/ada/s-tasque.adb632
-rw-r--r--gcc/ada/s-tasque.ads102
-rw-r--r--gcc/ada/s-tasren.adb1815
-rw-r--r--gcc/ada/s-tasren.ads150
-rw-r--r--gcc/ada/s-tasres.ads40
-rw-r--r--gcc/ada/s-tassta.adb1549
-rw-r--r--gcc/ada/s-tassta.ads274
-rw-r--r--gcc/ada/s-tasuti.adb570
-rw-r--r--gcc/ada/s-tasuti.ads104
-rw-r--r--gcc/ada/s-tataat.adb225
-rw-r--r--gcc/ada/s-tataat.ads121
-rw-r--r--gcc/ada/s-tpinop.adb83
-rw-r--r--gcc/ada/s-tpinop.ads54
-rw-r--r--gcc/ada/s-tpoben.adb248
-rw-r--r--gcc/ada/s-tpoben.ads189
-rw-r--r--gcc/ada/s-tpobop.adb981
-rw-r--r--gcc/ada/s-tpobop.ads207
-rw-r--r--gcc/ada/s-tposen.adb599
-rw-r--r--gcc/ada/s-tposen.ads295
-rw-r--r--gcc/ada/s-traceb.adb79
-rw-r--r--gcc/ada/s-traceb.ads84
-rw-r--r--gcc/ada/s-unstyp.ads234
-rw-r--r--gcc/ada/s-vaflop.adb421
-rw-r--r--gcc/ada/s-vaflop.ads215
-rw-r--r--gcc/ada/s-valboo.adb66
-rw-r--r--gcc/ada/s-valboo.ads42
-rw-r--r--gcc/ada/s-valcha.adb77
-rw-r--r--gcc/ada/s-valcha.ads42
-rw-r--r--gcc/ada/s-valdec.adb74
-rw-r--r--gcc/ada/s-valdec.ads84
-rw-r--r--gcc/ada/s-valenu.adb158
-rw-r--r--gcc/ada/s-valenu.ads84
-rw-r--r--gcc/ada/s-valint.adb101
-rw-r--r--gcc/ada/s-valint.ads78
-rw-r--r--gcc/ada/s-vallld.adb77
-rw-r--r--gcc/ada/s-vallld.ads87
-rw-r--r--gcc/ada/s-vallli.adb103
-rw-r--r--gcc/ada/s-vallli.ads78
-rw-r--r--gcc/ada/s-valllu.adb304
-rw-r--r--gcc/ada/s-valllu.ads83
-rw-r--r--gcc/ada/s-valrea.adb336
-rw-r--r--gcc/ada/s-valrea.ads75
-rw-r--r--gcc/ada/s-valuns.adb298
-rw-r--r--gcc/ada/s-valuns.ads83
-rw-r--r--gcc/ada/s-valuti.adb289
-rw-r--r--gcc/ada/s-valuti.ads110
-rw-r--r--gcc/ada/s-valwch.adb114
-rw-r--r--gcc/ada/s-valwch.ads47
-rw-r--r--gcc/ada/s-vercon.adb60
-rw-r--r--gcc/ada/s-vercon.ads57
-rw-r--r--gcc/ada/s-vmexta.adb164
-rw-r--r--gcc/ada/s-vmexta.ads55
-rw-r--r--gcc/ada/s-wchcnv.adb305
-rw-r--r--gcc/ada/s-wchcnv.ads68
-rw-r--r--gcc/ada/s-wchcon.ads176
-rw-r--r--gcc/ada/s-wchjis.adb173
-rw-r--r--gcc/ada/s-wchjis.ads80
-rw-r--r--gcc/ada/s-wchstw.adb221
-rw-r--r--gcc/ada/s-wchstw.ads62
-rw-r--r--gcc/ada/s-wchwts.adb165
-rw-r--r--gcc/ada/s-wchwts.ads61
-rw-r--r--gcc/ada/s-widboo.adb55
-rw-r--r--gcc/ada/s-widboo.ads45
-rw-r--r--gcc/ada/s-widcha.adb60
-rw-r--r--gcc/ada/s-widcha.ads45
-rw-r--r--gcc/ada/s-widenu.adb133
-rw-r--r--gcc/ada/s-widenu.ads77
-rw-r--r--gcc/ada/s-widlli.adb77
-rw-r--r--gcc/ada/s-widlli.ads49
-rw-r--r--gcc/ada/s-widllu.adb77
-rw-r--r--gcc/ada/s-widllu.ads51
-rw-r--r--gcc/ada/s-widwch.adb102
-rw-r--r--gcc/ada/s-widwch.ads51
-rw-r--r--gcc/ada/s-wwdcha.adb60
-rw-r--r--gcc/ada/s-wwdcha.ads45
-rw-r--r--gcc/ada/s-wwdenu.adb163
-rw-r--r--gcc/ada/s-wwdenu.ads84
-rw-r--r--gcc/ada/s-wwdwch.adb77
-rw-r--r--gcc/ada/s-wwdwch.ads48
366 files changed, 55727 insertions, 0 deletions
diff --git a/gcc/ada/s-addima.adb b/gcc/ada/s-addima.adb
new file mode 100644
index 00000000000..dcfc5053307
--- /dev/null
+++ b/gcc/ada/s-addima.adb
@@ -0,0 +1,76 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with 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 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 00000000000..34c2ef7769a
--- /dev/null
+++ b/gcc/ada/s-addima.ads
@@ -0,0 +1,43 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A D D R E S S _ I M A G E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNAT specific addition which provides a useful debugging
+-- procedure that gives an (implementation dependent) string which
+-- identifies an address.
+
+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-arit64.adb b/gcc/ada/s-arit64.adb
new file mode 100644
index 00000000000..f4c8532ee3f
--- /dev/null
+++ b/gcc/ada/s-arit64.adb
@@ -0,0 +1,719 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . A R I T H _ 6 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.16 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Exceptions; use GNAT.Exceptions;
+
+with Interfaces; use Interfaces;
+with 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 Unchecked_Conversion (Int64, Uns64);
+ function To_Int is new 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 : Uns64; B : Uns32) return Uns64;
+ pragma Inline ("-");
+ -- Length doubling subtraction
+
+ function "*" (A, B : Uns32) return Uns64;
+ function "*" (A : Uns64; B : Uns32) return Uns64;
+ pragma Inline ("*");
+ -- Length doubling multiplications
+
+ 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 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
+
+ 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 : Uns64; B : Uns32) return Uns64 is
+ begin
+ return 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 "-";
+
+ ---------
+ -- "/" --
+ ---------
+
+ 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
+ if Zhi /= 0 then
+ T2 := Ylo * Zhi;
+ else
+ T2 := 0;
+ end if;
+ 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);
+ 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;
+
+ -- Set final signs (RM 4.5.5(27-30))
+
+ Den_Pos := (Y < 0) = (Z < 0);
+
+ -- Case of dividend (X) sign positive
+
+ if X >= 0 then
+ R := To_Int (Ru);
+
+ if Den_Pos then
+ Q := To_Int (Qu);
+ else
+ Q := -To_Int (Qu);
+ end if;
+
+ -- Case of dividend (X) sign negative
+
+ else
+ R := -To_Int (Ru);
+
+ if Den_Pos then
+ Q := -To_Int (Qu);
+ else
+ Q := To_Int (Qu);
+ end if;
+ end if;
+ end Double_Divide;
+
+ --------
+ -- Hi --
+ --------
+
+ function Hi (A : Uns64) return Uns32 is
+ begin
+ return Uns32 (Shift_Right (A, 32));
+ end Hi;
+
+ --------
+ -- 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;
+
+ else
+ if Yhi /= 0 then
+ T2 := Xlo * Yhi;
+ else
+ return X * Y;
+ end if;
+ end if;
+
+ 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_Exception (CE, "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);
+
+ D1, D2, D3, D4 : Uns32;
+ -- The dividend, four digits (D1 is high order)
+
+ Q1, Q2 : Uns32;
+ -- The quotient, two digits (Q1 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;
+ D4 := Lo (T1);
+ D3 := Hi (T1);
+
+ if Yhi /= 0 then
+ T1 := Xlo * Yhi;
+ T2 := D3 + Lo (T1);
+ D3 := Lo (T2);
+ D2 := Hi (T1) + Hi (T2);
+
+ if Xhi /= 0 then
+ T1 := Xhi * Ylo;
+ T2 := D3 + Lo (T1);
+ D3 := Lo (T2);
+ T3 := D2 + Hi (T1);
+ T3 := T3 + Hi (T2);
+ D2 := Lo (T3);
+ D1 := Hi (T3);
+
+ T1 := (D1 & D2) + Uns64'(Xhi * Yhi);
+ D1 := Hi (T1);
+ D2 := Lo (T1);
+
+ else
+ D1 := 0;
+ end if;
+
+ else
+ if Xhi /= 0 then
+ T1 := Xhi * Ylo;
+ T2 := D3 + Lo (T1);
+ D3 := Lo (T2);
+ D2 := Hi (T1) + Hi (T2);
+
+ else
+ D2 := 0;
+ end if;
+
+ D1 := 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 D1 /= 0 or else D2 >= Zlo then
+ Raise_Error;
+
+ -- Here we are dividing at most three digits by one digit
+
+ else
+ T1 := D2 & D3;
+ T2 := Lo (T1 rem Zlo) & D4;
+
+ Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo);
+ Ru := T2 rem Zlo;
+ end if;
+
+ -- If divisor is double digit and too large, raise error
+
+ elsif (D1 & D2) >= 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 (D1 & D2) >= Zu.
+
+ T1 := Shift_Left (D1 & D2, Scale);
+ D1 := Hi (T1);
+ T2 := Shift_Left (0 & D3, Scale);
+ D2 := Lo (T1) or Hi (T2);
+ T3 := Shift_Left (0 & D4, Scale);
+ D3 := Lo (T2) or Hi (T3);
+ D4 := Lo (T3);
+
+ -- Compute first quotient digit. We have to divide three digits by
+ -- two digits, and 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.
+
+ if D1 = Zhi then
+ Q1 := 2 ** 32 - 1;
+ else
+ Q1 := Lo ((D1 & D2) / Zhi);
+ end if;
+
+ -- Compute amount to subtract
+
+ T1 := Q1 * Zlo;
+ T2 := Q1 * 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 S1 < D1;
+
+ if S1 = D1 then
+ exit when S2 < D2;
+
+ if S2 = D2 then
+ exit when S3 <= D3;
+ end if;
+ end if;
+
+ Q1 := Q1 - 1;
+
+ T1 := (S2 & S3) - Zlo;
+ S3 := Lo (T1);
+ T1 := (S1 & S2) - Zhi;
+ S2 := Lo (T1);
+ S1 := Hi (T1);
+ end loop;
+
+ -- Subtract from dividend (note: do not bother to set D1 to
+ -- zero, since it is no longer needed in the calculation).
+
+ T1 := (D2 & D3) - S3;
+ D3 := Lo (T1);
+ T1 := (D1 & Hi (T1)) - S2;
+ D2 := Lo (T1);
+
+ -- Compute second quotient digit in same manner
+
+ if D2 = Zhi then
+ Q2 := 2 ** 32 - 1;
+ else
+ Q2 := Lo ((D2 & D3) / Zhi);
+ end if;
+
+ T1 := Q2 * Zlo;
+ T2 := Q2 * Zhi;
+ S3 := Lo (T1);
+ T1 := Hi (T1) + Lo (T2);
+ S2 := Lo (T1);
+ S1 := Hi (T1) + Hi (T2);
+
+ loop
+ exit when S1 < D2;
+
+ if S1 = D2 then
+ exit when S2 < D3;
+
+ if S2 = D3 then
+ exit when S3 <= D4;
+ end if;
+ end if;
+
+ Q2 := Q2 - 1;
+
+ T1 := (S2 & S3) - Zlo;
+ S3 := Lo (T1);
+ T1 := (S1 & S2) - Zhi;
+ S2 := Lo (T1);
+ S1 := Hi (T1);
+ end loop;
+
+ T1 := (D3 & D4) - S3;
+ D4 := Lo (T1);
+ T1 := (D2 & Hi (T1)) - S2;
+ D3 := Lo (T1);
+
+ -- 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 := Q1 & Q2;
+ Ru := Shift_Right (D3 & D4, 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);
+
+ if Z > 0 then
+ Q := To_Pos_Int (Qu);
+ else
+ Q := To_Neg_Int (Qu);
+ end if;
+
+ -- Case of dividend (X * Y) sign negative
+
+ else
+ R := To_Neg_Int (Ru);
+
+ if Z > 0 then
+ Q := To_Neg_Int (Qu);
+ else
+ Q := To_Pos_Int (Qu);
+ end if;
+ end if;
+
+ end Scaled_Divide;
+
+ -------------------------------
+ -- 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 00000000000..d32bbaab2a5
--- /dev/null
+++ b/gcc/ada/s-arit64.ads
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A R I T H _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Arith_64);
+
+ 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 difference.
+
+ 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.
+ -- 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. The
+ -- result is known to be in range except for the noted possibility of
+ -- Y or Z being zero, so no other overflow checks are required.
+
+end System.Arith_64;
diff --git a/gcc/ada/s-assert.adb b/gcc/ada/s-assert.adb
new file mode 100644
index 00000000000..c070cc626fa
--- /dev/null
+++ b/gcc/ada/s-assert.adb
@@ -0,0 +1,49 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . A S S E R T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+
+package body System.Assertions is
+
+ --------------------------
+ -- Raise_Assert_Failure --
+ --------------------------
+
+ procedure Raise_Assert_Failure (Msg : String) is
+ begin
+ 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 00000000000..45fe11c88f3
--- /dev/null
+++ b/gcc/ada/s-assert.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . A S S E R T I O N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.11 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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.adb b/gcc/ada/s-asthan.adb
new file mode 100644
index 00000000000..8247ec7a153
--- /dev/null
+++ b/gcc/ada/s-asthan.adb
@@ -0,0 +1,75 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1996-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the dummy version used on non-VMS systems
+
+with Ada.Exceptions;
+with Ada.Task_Identification;
+with System.Aux_DEC;
+
+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
+ Ada.Exceptions.Raise_Exception
+ (E => Program_Error'Identity,
+ Message => "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 : in Natural;
+ Actual_Number : out Natural;
+ Total_Number : out Natural)
+ is
+ begin
+ Ada.Exceptions.Raise_Exception
+ (E => Program_Error'Identity,
+ Message => "AST is implemented only on VMS systems");
+
+ Actual_Number := 0;
+ Total_Number := 0;
+ 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 00000000000..4f19483a26e
--- /dev/null
+++ b/gcc/ada/s-asthan.ads
@@ -0,0 +1,63 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . A S T _ H A N D L I N G --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 : in 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 00000000000..7d2842cfcba
--- /dev/null
+++ b/gcc/ada/s-atacco.adb
@@ -0,0 +1,63 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+package body System.Address_To_Access_Conversions is
+
+ ----------------
+ -- To_Address --
+ ----------------
+
+ function To_Address (Value : Object_Pointer) return Address is
+ begin
+ if Value = null then
+ return Null_Address;
+ else
+ return Value.all'Address;
+ end if;
+ end To_Address;
+
+ ----------------
+ -- To_Pointer --
+ ----------------
+
+ function To_Pointer (Value : Address) return Object_Pointer is
+ function A_To_P is new Unchecked_Conversion (Address, Object_Pointer);
+
+ begin
+ return A_To_P (Value);
+ end To_Pointer;
+
+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 00000000000..e5db1ee268a
--- /dev/null
+++ b/gcc/ada/s-atacco.ads
@@ -0,0 +1,33 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you 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;
+
+package System.Address_To_Access_Conversions is
+pragma Preelaborate (Address_To_Access_Conversions);
+
+ type Object_Pointer is access all Object;
+ for Object_Pointer'Size use Standard'Address_Size;
+
+ function To_Pointer (Value : Address) return Object_Pointer;
+ function To_Address (Value : Object_Pointer) return Address;
+
+ pragma Convention (Intrinsic, To_Pointer);
+ pragma Convention (Intrinsic, To_Address);
+
+end System.Address_To_Access_Conversions;
diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb
new file mode 100644
index 00000000000..e16cf6acbb0
--- /dev/null
+++ b/gcc/ada/s-auxdec.adb
@@ -0,0 +1,709 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A U X _ D E C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada COre Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 Unchecked_Conversion (LIU, Largest_Integer);
+ function From_LI is new 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 Unchecked_Conversion (SA, Address);
+ function From_A is new 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 - 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 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 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 Unchecked_Conversion (BU, Unsigned_Byte);
+ function From_B is new 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 Unchecked_Conversion (WU, Unsigned_Word);
+ function From_W is new 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 Unchecked_Conversion (LWU, Unsigned_Longword);
+ function From_LW is new 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 Unchecked_Conversion (U32, Unsigned_32);
+ function From_U32 is new 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 Unchecked_Conversion (QWU, Unsigned_Quadword);
+ function From_QW is new 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 : in Natural;
+ Success_Flag : out Boolean)
+ is
+ 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 : in Natural;
+ Success_Flag : out Boolean)
+ is
+ 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 : in 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 : in 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 : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean)
+ is
+ 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 : in 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 : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean)
+ is
+ 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 Unchecked_Conversion (Integer, IU);
+ function From_IU is new Unchecked_Conversion (IU, Integer);
+
+ function To_LU is new Unchecked_Conversion (Long_Integer, LU);
+ function From_LU is new Unchecked_Conversion (LU, Long_Integer);
+
+ procedure And_Atomic
+ (To : in out Aligned_Integer;
+ From : in 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 : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean)
+ is
+ 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 : in 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 : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean)
+ is
+ 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 : in 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 : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean)
+ is
+ 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 : in 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 : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean)
+ is
+ 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 Unchecked_Conversion (Address, QR_Ptr);
+ function From_QR_Ptr is new Unchecked_Conversion (QR_Ptr, Address);
+
+ ------------
+ -- Insqhi --
+ ------------
+
+ procedure Insqhi
+ (Item : in Address;
+ Header : in 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 : in 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 : in Address;
+ Header : in 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 : in 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 00000000000..fc1f4ac653a
--- /dev/null
+++ b/gcc/ada/s-auxdec.ads
@@ -0,0 +1,556 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . A U X _ D E C --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.24 $
+-- --
+-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 Unchecked_Conversion;
+
+package System.Aux_DEC is
+pragma Elaborate_Body (Aux_DEC);
+
+ 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 Largest_Integer is range Min_Int .. Max_Int;
+
+ type AST_Handler is limited 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;
+
+ 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);
+
+ 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 : in Natural;
+ Success_Flag : out Boolean);
+
+ procedure Set_Interlocked
+ (Bit : in out Boolean;
+ Old_Value : out Boolean;
+ Retry_Count : in Natural;
+ Success_Flag : out Boolean);
+
+ procedure Add_Interlocked
+ (Addend : in 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 : in Integer);
+
+ procedure Add_Atomic
+ (To : in out Aligned_Integer;
+ Amount : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean);
+
+ procedure Add_Atomic
+ (To : in out Aligned_Long_Integer;
+ Amount : in Long_Integer);
+
+ procedure Add_Atomic
+ (To : in out Aligned_Long_Integer;
+ Amount : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean);
+
+ procedure And_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer);
+
+ procedure And_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean);
+
+ procedure And_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer);
+
+ procedure And_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Long_Integer;
+ Success_Flag : out Boolean);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Integer;
+ From : in Integer;
+ Retry_Count : in Natural;
+ Old_Value : out Integer;
+ Success_Flag : out Boolean);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer);
+
+ procedure Or_Atomic
+ (To : in out Aligned_Long_Integer;
+ From : in Long_Integer;
+ Retry_Count : in 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 : in Address;
+ Header : in Address;
+ Status : out Insq_Status);
+
+ procedure Remqhi
+ (Header : in Address;
+ Item : out Address;
+ Status : out Remq_Status);
+
+ procedure Insqti
+ (Item : in Address;
+ Header : in Address;
+ Status : out Insq_Status);
+
+ procedure Remqti
+ (Header : in 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 ("+");
+ pragma Inline ("-");
+ pragma Inline ("not");
+ pragma Inline ("and");
+ pragma Inline ("or");
+ pragma Inline ("xor");
+
+ -- Other inlined subprograms
+
+ pragma Inline (Fetch_From_Address);
+ pragma Inline (Assign_To_Address);
+
+ -- 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ Unchecked_Conversion (Address, Integer);
+
+ function To_Integer (X : Address) return Integer
+ renames To_Integer_A;
+
+ function To_Unsigned_Longword_A is new
+ 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
+ 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 00000000000..6b5538c30d4
--- /dev/null
+++ b/gcc/ada/s-bitops.adb
@@ -0,0 +1,223 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . B I T _ O P S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1996-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Exceptions; use GNAT.Exceptions;
+with System; use System;
+with System.Unsigned_Types; use System.Unsigned_Types;
+with Unchecked_Conversion;
+
+package body System.Bit_Ops is
+
+ subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive);
+ -- Unconstrained array used to interprete 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).
+
+ type Bits is access Bits_Array;
+ -- This is the actual type into which address values are converted
+
+ function To_Bits is new 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;
+ -- 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 Llen /= Rlen then
+ return False;
+
+ elsif 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 (CE, "unequal lengths in logical operation");
+ 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 00000000000..e925247e746
--- /dev/null
+++ b/gcc/ada/s-bitops.ads
@@ -0,0 +1,101 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . B I T _ O P S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Operations on packed bit strings
+
+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.
+
+ procedure Bit_And
+ (Left : System.Address;
+ Llen : Natural;
+ Right : Address;
+ Rlen : Natural;
+ Result : System.Address);
+ -- Bitwise "and" 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).
+
+ 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 : 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 : Address;
+ Rlen : Natural;
+ Result : System.Address);
+ -- Bitwise "xor" 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).
+
+end System.Bit_Ops;
diff --git a/gcc/ada/s-chepoo.ads b/gcc/ada/s-chepoo.ads
new file mode 100644
index 00000000000..bf368858b8e
--- /dev/null
+++ b/gcc/ada/s-chepoo.ads
@@ -0,0 +1,76 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 Allocate
+ (Pool : in out Checked_Pool;
+ Storage_Address : out Address;
+ Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
+ Alignment : in System.Storage_Elements.Storage_Count)
+ is abstract;
+
+ procedure Deallocate
+ (Pool : in out Checked_Pool;
+ Storage_Address : in Address;
+ Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
+ Alignment : in System.Storage_Elements.Storage_Count)
+ is abstract;
+
+ function Storage_Size
+ (Pool : Checked_Pool)
+ return System.Storage_Elements.Storage_Count
+ is abstract;
+
+ procedure Dereference
+ (Pool : in out Checked_Pool;
+ Storage_Address : in Address;
+ Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
+ Alignment : in System.Storage_Elements.Storage_Count)
+ is abstract;
+ -- Called each time a pointer to a checked pool is dereferenced
+
+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-direio.adb b/gcc/ada/s-direio.adb
new file mode 100644
index 00000000000..1aeb84149a4
--- /dev/null
+++ b/gcc/ada/s-direio.adb
@@ -0,0 +1,377 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . D I R E C T _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.17 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions; use Ada.IO_Exceptions;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System; use System;
+with System.File_IO;
+with System.Soft_Links;
+with 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;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Set_Position (File : in 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
+ begin
+ return new Direct_AFCB;
+ end AFCB_Allocate;
+
+ ----------------
+ -- AFCB_Close --
+ ----------------
+
+ -- No special processing required for Direct_IO close
+
+ procedure AFCB_Close (File : access Direct_AFCB) is
+ begin
+ null;
+ end AFCB_Close;
+
+ ---------------
+ -- AFCB_Free --
+ ---------------
+
+ procedure AFCB_Free (File : access Direct_AFCB) is
+
+ type FCB_Ptr is access all Direct_AFCB;
+
+ FT : FCB_Ptr := FCB_Ptr (File);
+
+ procedure Free is new
+ Unchecked_Deallocation (Direct_AFCB, FCB_Ptr);
+
+ begin
+ Free (FT);
+ end AFCB_Free;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create
+ (File : in out File_Type;
+ Mode : in FCB.File_Mode := FCB.Inout_File;
+ Name : in String := "";
+ Form : in String := "")
+ is
+ File_Control_Block : Direct_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => 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 : in File_Type) return Boolean is
+ begin
+ FIO.Check_Read_Status (AP (File));
+ return Count (File.Index) > Size (File);
+ end End_Of_File;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index (File : in File_Type) return Positive_Count is
+ begin
+ FIO.Check_File_Open (AP (File));
+ return Count (File.Index);
+ end Index;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : in FCB.File_Mode;
+ Name : in String;
+ Form : in String := "")
+ is
+ File_Control_Block : Direct_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => File_Control_Block,
+ Mode => Mode,
+ Name => Name,
+ Form => Form,
+ Amethod => 'D',
+ Creat => False,
+ Text => False);
+ end Open;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (File : in File_Type;
+ Item : Address;
+ Size : in Interfaces.C_Streams.size_t;
+ From : in Positive_Count)
+ is
+ begin
+ Set_Index (File, From);
+ Read (File, Item, Size);
+ end Read;
+
+ procedure Read
+ (File : in File_Type;
+ Item : Address;
+ Size : in 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.
+
+ if File.Bytes = Size then
+ File.Last_Op := Op_Read;
+ else
+ File.Last_Op := Op_Other;
+ end if;
+ 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 : in FCB.File_Mode) is
+ begin
+ FIO.Reset (AP (File), Mode);
+ File.Index := 1;
+ File.Last_Op := Op_Read;
+ end Reset;
+
+ procedure Reset (File : in out File_Type) is
+ begin
+ FIO.Reset (AP (File));
+ File.Index := 1;
+ File.Last_Op := Op_Read;
+ end Reset;
+
+ ---------------
+ -- Set_Index --
+ ---------------
+
+ procedure Set_Index (File : in File_Type; To : in 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 : in 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 : in 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 : in Interfaces.C_Streams.size_t;
+ Zeroes : System.Storage_Elements.Storage_Array)
+
+ is
+ procedure Do_Write;
+ -- Do the actual 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.
+
+ if File.Bytes = Size then
+ File.Last_Op := Op_Write;
+ else
+ File.Last_Op := Op_Other;
+ end if;
+ 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 : in 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 00000000000..333a8046188
--- /dev/null
+++ b/gcc/ada/s-direio.ads
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . D I R E C T _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 : access Direct_AFCB);
+ procedure AFCB_Free (File : 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 : in 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 : in FCB.File_Mode := FCB.Inout_File;
+ Name : in String := "";
+ Form : in String := "");
+
+ function End_Of_File (File : in File_Type) return Boolean;
+
+ function Index (File : in File_Type) return Positive_Count;
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : in FCB.File_Mode;
+ Name : in String;
+ Form : in String := "");
+
+ procedure Read
+ (File : in File_Type;
+ Item : System.Address;
+ Size : in Interfaces.C_Streams.size_t;
+ From : in Positive_Count);
+
+ procedure Read
+ (File : in File_Type;
+ Item : System.Address;
+ Size : in Interfaces.C_Streams.size_t);
+
+ procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode);
+
+ procedure Reset (File : in out File_Type);
+
+ procedure Set_Index (File : in File_Type; To : in Positive_Count);
+
+ function Size (File : in File_Type) return Count;
+
+ procedure Write
+ (File : in File_Type;
+ Item : System.Address;
+ Size : in Interfaces.C_Streams.size_t;
+ Zeroes : System.Storage_Elements.Storage_Array);
+ -- Note: Zeroes is the buffer of zeroes used to fill out partial records
+
+end System.Direct_IO;
diff --git a/gcc/ada/s-errrep.adb b/gcc/ada/s-errrep.adb
new file mode 100644
index 00000000000..7c3450a8561
--- /dev/null
+++ b/gcc/ada/s-errrep.adb
@@ -0,0 +1,71 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . E R R O R _ R E P O R T I N G --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $ --
+-- --
+-- Copyright (C) 1991-2000 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package must not depend on anything else, since it may be
+-- called during elaboration of other packages.
+
+package body System.Error_Reporting is
+
+ procedure Write (fildes : Integer; buf : System.Address; nbyte : Integer);
+ pragma Import (C, Write, "write");
+
+ procedure Prog_Exit (Status : Integer);
+ pragma No_Return (Prog_Exit);
+ pragma Import (C, Prog_Exit, "exit");
+
+ Shutdown_Message : String := "failed run-time assertion : ";
+ End_Of_Line : String := "" & ASCII.LF;
+
+ --------------
+ -- Shutdown --
+ --------------
+
+ function Shutdown (M : in String) return Boolean is
+ begin
+ Write (2, Shutdown_Message'Address, Shutdown_Message'Length);
+ Write (2, M'Address, M'Length);
+ Write (2, End_Of_Line'Address, End_Of_Line'Length);
+
+ -- This call should never return
+
+ Prog_Exit (1);
+
+ -- Return is just to keep Ada happy (return required)
+
+ return False;
+ end Shutdown;
+
+end System.Error_Reporting;
diff --git a/gcc/ada/s-errrep.ads b/gcc/ada/s-errrep.ads
new file mode 100644
index 00000000000..923b9091274
--- /dev/null
+++ b/gcc/ada/s-errrep.ads
@@ -0,0 +1,48 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . E R R O R _ R E P O R T I N G --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.11 $ --
+-- --
+-- Copyright (C) 1991-1998 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package must not depend on anything else, since it may be
+-- called during elaboration of other packages.
+
+package System.Error_Reporting is
+ pragma Preelaborate;
+
+ function Shutdown (M : in String) return Boolean;
+ -- Perform emergency shutdown of the entire program.
+ -- Msg is an error message to be printed to the console.
+ -- This is to be used only for nonrecoverable errors.
+
+end System.Error_Reporting;
diff --git a/gcc/ada/s-except.ads b/gcc/ada/s-except.ads
new file mode 100644
index 00000000000..e277e8c3d1a
--- /dev/null
+++ b/gcc/ada/s-except.ads
@@ -0,0 +1,205 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains definitions used for zero cost exception handling.
+-- See unit Ada.Exceptions for further details. Note that the reason that
+-- we separate out these definitions is to avoid problems with recursion
+-- in rtsfind. They must be in a unit which does not require any exception
+-- table generation of any kind.
+
+with Ada.Exceptions;
+
+with System;
+with System.Standard_Library;
+
+with Unchecked_Conversion;
+
+package System.Exceptions is
+
+ package SSL renames System.Standard_Library;
+ package AEX renames Ada.Exceptions;
+
+ -- The following section defines data structures used for zero cost
+ -- exception handling if System.Parameters.Zero_Cost_Exceptions is
+ -- set true (i.e. zero cost exceptions are implemented on this target).
+
+ -- The approach is to build tables that describe the PC ranges that
+ -- are covered by various exception frames. When an exception occurs,
+ -- these tables are searched to determine the address of the applicable
+ -- handler for the current exception.
+
+ subtype Handler_Loc is System.Address;
+ -- Code location representing entry address of a handler. Values of
+ -- this type are created using the N_Handler_Loc node, and then
+ -- passed to the Enter_Handler procedure to enter a handler.
+
+ 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.
+
+ --------------------
+ -- Handler_Record --
+ --------------------
+
+ -- A Handler record is built for each choice for each exception handler
+ -- in a frame.
+
+ function To_Exception_Id is
+ new Unchecked_Conversion (SSL.Exception_Data_Ptr, AEX.Exception_Id);
+
+ Others_Dummy_Exception : aliased SSL.Exception_Data;
+ Others_Id : constant AEX.Exception_Id :=
+ To_Exception_Id (Others_Dummy_Exception'Access);
+ -- Dummy exception used to signal others exception
+
+ All_Others_Dummy_Exception : aliased SSL.Exception_Data;
+ All_Others_Id : constant AEX.Exception_Id :=
+ To_Exception_Id (All_Others_Dummy_Exception'Access);
+ -- Dummy exception used to signal all others exception (including
+ -- exceptions not normally handled by others, e.g. Abort_Signal)
+
+ type Handler_Record is record
+ Lo : Code_Loc;
+ Hi : Code_Loc;
+ -- Range of PC values of code covered by this handler record. The
+ -- handler covers all code addresses that are greater than the Lo
+ -- value, and less than or equal to the Hi value.
+
+ Id : AEX.Exception_Id;
+ -- Id of exception being handled, or one of the above special values
+
+ Handler : Handler_Loc;
+ -- Address of label at start of handler
+ end record;
+
+ type Handler_Record_Ptr is access all Handler_Record;
+ type Handler_Record_List is array (Natural range <>) of Handler_Record_Ptr;
+
+ ---------------------------
+ -- Subprogram_Descriptor --
+ ---------------------------
+
+ -- A Subprogram_Descriptor is built for each subprogram through which
+ -- exceptions may propagate, this includes all Ada subprograms,
+ -- and also all foreign language imported subprograms.
+
+ subtype Subprogram_Info_Type is System.Address;
+ -- This type is used to represent a value that is used to unwind stack
+ -- frames. It references target dependent data that provides sufficient
+ -- information (e.g. about the location of the return point, use of a
+ -- frame pointer, save-over-call registers etc) to unwind the machine
+ -- state to the caller. For some targets, this is simply a pointer to
+ -- the entry point of the procedure (and the routine to pop the machine
+ -- state disassembles the code at the entry point to obtain the required
+ -- information). On other targets, it is a pointer to data created by the
+ -- backend or assembler to represent the required information.
+
+ No_Info : constant Subprogram_Info_Type := System.Null_Address;
+ -- This is a special value used to indicate that it is not possible
+ -- to pop past this frame. This is used at the outer level (e.g. for
+ -- package elaboration procedures or the main procedure), and for any
+ -- other foreign language procedure for which propagation is known
+ -- to be impossible. An exception is considered unhandled if an
+ -- attempt is made to pop a frame whose Subprogram_Info_Type value
+ -- is set to No_Info.
+
+ type Subprogram_Descriptor (Num_Handlers : Natural) is record
+ Code : Code_Loc;
+ -- This is a code location used to determine which procedure we are
+ -- in. Most usually it is simply the entry address for the procedure.
+ -- hA given address is considered to be within the procedure referenced
+ -- by a Subprogram_Descriptor record if this is the descriptor for
+ -- which the Code value is as large as possible without exceeding
+ -- the given value.
+
+ Subprogram_Info : Subprogram_Info_Type;
+ -- This is a pointer to a target dependent data item that provides
+ -- sufficient information for unwinding the stack frame of this
+ -- procedure. A value of No_Info (zero) means that we are the
+ -- outer level procedure.
+
+ Handler_Records : Handler_Record_List (1 .. Num_Handlers);
+ -- List of pointers to Handler_Records for this procedure. The array
+ -- is sorted inside out, i.e. entries for inner frames appear before
+ -- entries for outer handlers. This ensures that a serial search
+ -- finds the innermost applicable handler
+ end record;
+
+ subtype Subprogram_Descriptor_0 is Subprogram_Descriptor (0);
+ subtype Subprogram_Descriptor_1 is Subprogram_Descriptor (1);
+ subtype Subprogram_Descriptor_2 is Subprogram_Descriptor (2);
+ subtype Subprogram_Descriptor_3 is Subprogram_Descriptor (3);
+ -- Predeclare commonly used subtypes for buildingt he tables
+
+ type Subprogram_Descriptor_Ptr is access all Subprogram_Descriptor;
+
+ type Subprogram_Descriptor_List
+ is array (Natural range <>) of Subprogram_Descriptor_Ptr;
+
+ type Subprogram_Descriptors_Record (Count : Natural) is record
+ SDesc : Subprogram_Descriptor_List (1 .. Count);
+ end record;
+
+ type Subprogram_Descriptors_Ptr is
+ access all Subprogram_Descriptors_Record;
+
+ --------------------------
+ -- Unit Exception_Table --
+ --------------------------
+
+ -- If a unit contains at least one subprogram, then a library level
+ -- declaration of the form:
+
+ -- Tnn : aliased constant Subprogram_Descriptors :=
+ -- (Count => n,
+ -- SDesc =>
+ -- (SD1'Unrestricted_Access,
+ -- SD2'Unrestricted_Access,
+ -- ...
+ -- SDn'Unrestricted_Access));
+ -- pragma Export (Ada, Tnn, "__gnat_unit_name__SDP");
+
+ -- is generated where the initializing expression is an array aggregate
+ -- whose elements are pointers to the generated subprogram descriptors
+ -- for the units.
+
+ -- Note: the ALI file contains the designation UX in each unit entry
+ -- if a unit exception table is generated.
+
+ -- The binder generates a list of addresses of pointers to these tables.
+
+end System.Exceptions;
diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb
new file mode 100644
index 00000000000..821f1860ccf
--- /dev/null
+++ b/gcc/ada/s-exctab.adb
@@ -0,0 +1,192 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.HTable;
+
+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 : Big_String_Ptr) return HTable_Headers;
+ function Equal (A, B : Big_String_Ptr) return Boolean;
+ function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr;
+
+ package Exception_HTable is new GNAT.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 => Big_String_Ptr,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (A, B : Big_String_Ptr) return Boolean is
+ J : Integer := 1;
+
+ begin
+ loop
+ if A (J) /= B (J) then
+ return False;
+
+ elsif A (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 Big_String_Ptr is
+ begin
+ return T.Full_Name;
+ end Get_Key;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Big_String_Ptr) return HTable_Headers is
+ type S is mod 2**8;
+
+ Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
+ Tmp : S := 0;
+ J : Positive;
+
+ begin
+ J := 1;
+ loop
+ if F (J) = ASCII.NUL then
+ return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
+ else
+ Tmp := Tmp xor S (Character'Pos (F (J)));
+ end if;
+ J := J + 1;
+ end loop;
+ end Hash;
+
+ ------------------------
+ -- Internal_Exception --
+ ------------------------
+
+ type String_Ptr is access all String;
+
+ function Internal_Exception (X : String) return Exception_Data_Ptr is
+ 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 (To_Ptr (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 then
+ Dyn_Copy := new String'(Copy);
+
+ Res :=
+ new Exception_Data'
+ (Not_Handled_By_Others => False,
+ Lang => 'A',
+ Name_Length => Copy'Length,
+ Full_Name => To_Ptr (Dyn_Copy.all'Address),
+ HTable_Ptr => null,
+ Import_Code => 0);
+
+ 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;
+
+ -----------------
+ -- 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;
+
+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 00000000000..e41cfe8ac03
--- /dev/null
+++ b/gcc/ada/s-exctab.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1996-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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
+
+ function Internal_Exception (X : String) return SSL.Exception_Data_Ptr;
+ -- Given an exception_name X, returns a pointer to the actual internal
+ -- exception data.
+
+end System.Exception_Table;
diff --git a/gcc/ada/s-exnflt.ads b/gcc/ada/s-exnflt.ads
new file mode 100644
index 00000000000..943ed5cbc05
--- /dev/null
+++ b/gcc/ada/s-exnflt.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Float exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_Flt is
+pragma Pure (Exn_Flt);
+
+ function Exn_Float is
+ new System.Exn_Gen.Exn_Float_Type (Float);
+
+end System.Exn_Flt;
diff --git a/gcc/ada/s-exngen.adb b/gcc/ada/s-exngen.adb
new file mode 100644
index 00000000000..1054463c55c
--- /dev/null
+++ b/gcc/ada/s-exngen.adb
@@ -0,0 +1,154 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ G E N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Exn_Gen is
+
+ --------------------
+ -- Exn_Float_Type --
+ --------------------
+
+ function Exn_Float_Type
+ (Left : Type_Of_Base;
+ Right : Integer)
+ return Type_Of_Base
+ is
+ pragma Suppress (Division_Check);
+ pragma Suppress (Overflow_Check);
+ pragma Suppress (Range_Check);
+
+ Result : Type_Of_Base := 1.0;
+ Factor : Type_Of_Base := 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
+ -- Division by this factor.
+
+ 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;
+
+ -- Negative exponent. For a zero base, we should arguably return an
+ -- infinity of the right sign, but it is not clear that there is
+ -- proper authorization to do so, so for now raise Constraint_Error???
+
+ elsif Factor = 0.0 then
+ raise Constraint_Error;
+
+ -- Here we have a non-zero base and a negative exponent
+
+ else
+ -- 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
+ 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;
+
+ exception
+
+ when Constraint_Error =>
+ return 0.0;
+ end;
+ end if;
+ end Exn_Float_Type;
+
+ ----------------------
+ -- Exn_Integer_Type --
+ ----------------------
+
+ -- Note that negative exponents get a constraint error because the
+ -- subtype of the Right argument (the exponent) is Natural.
+
+ function Exn_Integer_Type
+ (Left : Type_Of_Base;
+ Right : Natural)
+ return Type_Of_Base
+ is
+ pragma Suppress (Division_Check);
+ pragma Suppress (Overflow_Check);
+
+ Result : Type_Of_Base := 1;
+ Factor : Type_Of_Base := 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 Exn_Integer_Type;
+
+end System.Exn_Gen;
diff --git a/gcc/ada/s-exngen.ads b/gcc/ada/s-exngen.ads
new file mode 100644
index 00000000000..ebd7e2267ae
--- /dev/null
+++ b/gcc/ada/s-exngen.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ G E N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the generic functions which are instantiated with
+-- predefined integer and real types to generate the runtime exponentiation
+-- functions called by expanded code generated by Expand_Op_Expon. This
+-- version of the package contains routines that are compiled with overflow
+-- checks suppressed, so they are called for exponentiation operations which
+-- do not require overflow checking
+
+package System.Exn_Gen is
+pragma Pure (System.Exn_Gen);
+
+ -- Exponentiation for float types (checks off)
+
+ generic
+ type Type_Of_Base is digits <>;
+
+ function Exn_Float_Type
+ (Left : Type_Of_Base;
+ Right : Integer)
+ return Type_Of_Base;
+
+ -- Exponentiation for signed integer base
+
+ generic
+ type Type_Of_Base is range <>;
+
+ function Exn_Integer_Type
+ (Left : Type_Of_Base;
+ Right : Natural)
+ return Type_Of_Base;
+
+end System.Exn_Gen;
diff --git a/gcc/ada/s-exnint.ads b/gcc/ada/s-exnint.ads
new file mode 100644
index 00000000000..ea67e6dd148
--- /dev/null
+++ b/gcc/ada/s-exnint.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Integer exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_Int is
+pragma Pure (Exn_Int);
+
+ function Exn_Integer is
+ new System.Exn_Gen.Exn_Integer_Type (Integer);
+
+end System.Exn_Int;
diff --git a/gcc/ada/s-exnlfl.ads b/gcc/ada/s-exnlfl.ads
new file mode 100644
index 00000000000..50cc8917b94
--- /dev/null
+++ b/gcc/ada/s-exnlfl.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ L F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Float exponentiation (checks on)
+
+with System.Exn_Gen;
+
+package System.Exn_LFlt is
+pragma Pure (Exn_LFlt);
+
+ function Exn_Long_Float is
+ new System.Exn_Gen.Exn_Float_Type (Long_Float);
+
+end System.Exn_LFlt;
diff --git a/gcc/ada/s-exnlin.ads b/gcc/ada/s-exnlin.ads
new file mode 100644
index 00000000000..76e2e32df6e
--- /dev/null
+++ b/gcc/ada/s-exnlin.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ L I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Integer exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_LInt is
+pragma Pure (Exn_LInt);
+
+ function Exn_Long_Integer is
+ new System.Exn_Gen.Exn_Integer_Type (Long_Integer);
+
+end System.Exn_LInt;
diff --git a/gcc/ada/s-exnllf.ads b/gcc/ada/s-exnllf.ads
new file mode 100644
index 00000000000..7155b0a9303
--- /dev/null
+++ b/gcc/ada/s-exnllf.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ L L F --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Long_Float exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_LLF is
+pragma Pure (Exn_LLF);
+
+ function Exn_Long_Long_Float is
+ new System.Exn_Gen.Exn_Float_Type (Long_Long_Float);
+
+end System.Exn_LLF;
diff --git a/gcc/ada/s-exnlli.ads b/gcc/ada/s-exnlli.ads
new file mode 100644
index 00000000000..7a2456a8e6c
--- /dev/null
+++ b/gcc/ada/s-exnlli.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ L L I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Long_Integer exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_LLI is
+pragma Pure (Exn_LLI);
+
+ function Exn_Long_Long_Integer is
+ new System.Exn_Gen.Exn_Integer_Type (Long_Long_Integer);
+
+end System.Exn_LLI;
diff --git a/gcc/ada/s-exnsfl.ads b/gcc/ada/s-exnsfl.ads
new file mode 100644
index 00000000000..1c19ac89804
--- /dev/null
+++ b/gcc/ada/s-exnsfl.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ S F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Short_Float exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_SFlt is
+pragma Pure (Exn_SFlt);
+
+ function Exn_Short_Float is
+ new System.Exn_Gen.Exn_Float_Type (Short_Float);
+
+end System.Exn_SFlt;
diff --git a/gcc/ada/s-exnsin.ads b/gcc/ada/s-exnsin.ads
new file mode 100644
index 00000000000..5623c85ba87
--- /dev/null
+++ b/gcc/ada/s-exnsin.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ S I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Short_Integer exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_SInt is
+pragma Pure (Exn_SInt);
+
+ function Exn_Short_Integer is
+ new System.Exn_Gen.Exn_Integer_Type (Short_Integer);
+
+end System.Exn_SInt;
diff --git a/gcc/ada/s-exnssi.ads b/gcc/ada/s-exnssi.ads
new file mode 100644
index 00000000000..4ff8f05609e
--- /dev/null
+++ b/gcc/ada/s-exnssi.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ S S I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Short_Short_Integer exponentiation (checks off)
+
+with System.Exn_Gen;
+
+package System.Exn_SSI is
+pragma Pure (Exn_SSI);
+
+ function Exn_Short_Short_Integer is
+ new System.Exn_Gen.Exn_Integer_Type (Short_Short_Integer);
+
+end System.Exn_SSI;
diff --git a/gcc/ada/s-expflt.ads b/gcc/ada/s-expflt.ads
new file mode 100644
index 00000000000..4460410f59d
--- /dev/null
+++ b/gcc/ada/s-expflt.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Float exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_Flt is
+pragma Pure (Exp_Flt);
+
+ function Exp_Float is new System.Exp_Gen.Exp_Float_Type (Float);
+
+end System.Exp_Flt;
diff --git a/gcc/ada/s-expgen.adb b/gcc/ada/s-expgen.adb
new file mode 100644
index 00000000000..4ae3c9830c6
--- /dev/null
+++ b/gcc/ada/s-expgen.adb
@@ -0,0 +1,183 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ G E N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Exp_Gen is
+
+ --------------------
+ -- Exp_Float_Type --
+ --------------------
+
+ function Exp_Float_Type
+ (Left : Type_Of_Base;
+ Right : Integer)
+ return Type_Of_Base
+ is
+ Result : Type_Of_Base := 1.0;
+ Factor : Type_Of_Base := 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.
+
+ 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;
+
+ return Result;
+
+ -- Now we know that the exponent is negative, check for case of
+ -- base of 0.0 which always generates a constraint error.
+
+ elsif Factor = 0.0 then
+ raise Constraint_Error;
+
+ -- Here we have a negative exponent with a non-zero base
+
+ else
+
+ -- 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 essenmtially have is
+ -- 1.0 / infinity, and the closest model number will be zero.
+
+ begin
+ 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;
+
+ declare
+ pragma Unsuppress (All_Checks);
+ begin
+ return 1.0 / Result;
+ end;
+
+ exception
+
+ when Constraint_Error =>
+ return 0.0;
+ end;
+ end if;
+ end Exp_Float_Type;
+
+ ----------------------
+ -- Exp_Integer_Type --
+ ----------------------
+
+ -- Note that negative exponents get a constraint error because the
+ -- subtype of the Right argument (the exponent) is Natural.
+
+ function Exp_Integer_Type
+ (Left : Type_Of_Base;
+ Right : Natural)
+ return Type_Of_Base
+ is
+ Result : Type_Of_Base := 1;
+ Factor : Type_Of_Base := 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
+ 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_Type;
+
+end System.Exp_Gen;
diff --git a/gcc/ada/s-expgen.ads b/gcc/ada/s-expgen.ads
new file mode 100644
index 00000000000..05b72a60d14
--- /dev/null
+++ b/gcc/ada/s-expgen.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ G E N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the generic functions which are instantiated with
+-- predefined integer and real types to generate the runtime exponentiation
+-- functions called by expanded code generated by Expand_Op_Expon. This
+-- version of the package contains routines that are compiled with overflow
+-- checks enabled, so they are called for exponentiation operations which
+-- require overflow checking
+
+package System.Exp_Gen is
+pragma Pure (System.Exp_Gen);
+
+ -- Exponentiation for float types (checks on)
+
+ generic
+ type Type_Of_Base is digits <>;
+
+ function Exp_Float_Type
+ (Left : Type_Of_Base;
+ Right : Integer)
+ return Type_Of_Base;
+
+ -- Exponentiation for signed integer types (checks on)
+
+ generic
+ type Type_Of_Base is range <>;
+
+ function Exp_Integer_Type
+ (Left : Type_Of_Base;
+ Right : Natural)
+ return Type_Of_Base;
+
+end System.Exp_Gen;
diff --git a/gcc/ada/s-expint.ads b/gcc/ada/s-expint.ads
new file mode 100644
index 00000000000..7a23fce46f3
--- /dev/null
+++ b/gcc/ada/s-expint.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Integer exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_Int is
+pragma Pure (Exp_Int);
+
+ function Exp_Integer is new System.Exp_Gen.Exp_Integer_Type (Integer);
+
+end System.Exp_Int;
diff --git a/gcc/ada/s-explfl.ads b/gcc/ada/s-explfl.ads
new file mode 100644
index 00000000000..34ec71b61d1
--- /dev/null
+++ b/gcc/ada/s-explfl.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ L F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Float exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_LFlt is
+pragma Pure (Exp_LFlt);
+
+ function Exp_Long_Float is
+ new System.Exp_Gen.Exp_Float_Type (Long_Float);
+
+end System.Exp_LFlt;
diff --git a/gcc/ada/s-explin.ads b/gcc/ada/s-explin.ads
new file mode 100644
index 00000000000..1c4b5247ca2
--- /dev/null
+++ b/gcc/ada/s-explin.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ L I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Integer exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_LInt is
+pragma Pure (Exp_LInt);
+
+ function Exp_Long_Integer is
+ new System.Exp_Gen.Exp_Integer_Type (Long_Integer);
+
+end System.Exp_LInt;
diff --git a/gcc/ada/s-expllf.ads b/gcc/ada/s-expllf.ads
new file mode 100644
index 00000000000..253a9577f10
--- /dev/null
+++ b/gcc/ada/s-expllf.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ L L F --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Long_Float exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_LLF is
+pragma Pure (Exp_LLF);
+
+ function Exp_Long_Long_Float is
+ new System.Exp_Gen.Exp_Float_Type (Long_Long_Float);
+
+end System.Exp_LLF;
diff --git a/gcc/ada/s-explli.ads b/gcc/ada/s-explli.ads
new file mode 100644
index 00000000000..beb545b03b1
--- /dev/null
+++ b/gcc/ada/s-explli.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ L L I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Long_Integer exponentiation
+
+with System.Exp_Gen;
+
+package System.Exp_LLI is
+pragma Pure (Exp_LLI);
+
+ function Exp_Long_Long_Integer is
+ new System.Exp_Gen.Exp_Integer_Type (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 00000000000..39f3144a3a1
--- /dev/null
+++ b/gcc/ada/s-expllu.adb
@@ -0,0 +1,78 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . X P _ B M L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..b75420920f8
--- /dev/null
+++ b/gcc/ada/s-expllu.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ L L U --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Exp_LLU);
+
+ 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 00000000000..a87002bcbf1
--- /dev/null
+++ b/gcc/ada/s-expmod.adb
@@ -0,0 +1,91 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ M O D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..79f6400a3a6
--- /dev/null
+++ b/gcc/ada/s-expmod.ads
@@ -0,0 +1,49 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ M O D --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Exp_Mod);
+
+ function Exp_Modular
+ (Left : Integer;
+ Modulus : Integer;
+ Right : Natural)
+ return Integer;
+
+end System.Exp_Mod;
diff --git a/gcc/ada/s-expsfl.ads b/gcc/ada/s-expsfl.ads
new file mode 100644
index 00000000000..cfabd1650a6
--- /dev/null
+++ b/gcc/ada/s-expsfl.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ S F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Short_Float exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_SFlt is
+pragma Pure (Exp_SFlt);
+
+ function Exp_Short_Float is
+ new System.Exp_Gen.Exp_Float_Type (Short_Float);
+
+end System.Exp_SFlt;
diff --git a/gcc/ada/s-expsin.ads b/gcc/ada/s-expsin.ads
new file mode 100644
index 00000000000..c5bc2c3054b
--- /dev/null
+++ b/gcc/ada/s-expsin.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ S I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Short_Integer exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_SInt is
+pragma Pure (Exp_SInt);
+
+ function Exp_Short_Integer is
+ new System.Exp_Gen.Exp_Integer_Type (Short_Integer);
+
+end System.Exp_SInt;
diff --git a/gcc/ada/s-expssi.ads b/gcc/ada/s-expssi.ads
new file mode 100644
index 00000000000..802412d56c6
--- /dev/null
+++ b/gcc/ada/s-expssi.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P S S I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Short_Short_Integer exponentiation (checks on)
+
+with System.Exp_Gen;
+
+package System.Exp_SSI is
+pragma Pure (Exp_SSI);
+
+ function Exp_Short_Short_Integer is
+ new System.Exp_Gen.Exp_Integer_Type (Short_Short_Integer);
+
+end System.Exp_SSI;
diff --git a/gcc/ada/s-expuns.adb b/gcc/ada/s-expuns.adb
new file mode 100644
index 00000000000..a02a6994cb4
--- /dev/null
+++ b/gcc/ada/s-expuns.adb
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ U N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..9d4989bf16b
--- /dev/null
+++ b/gcc/ada/s-expuns.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P _ U N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Exp_Uns);
+
+ 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 00000000000..b27d4b2b839
--- /dev/null
+++ b/gcc/ada/s-fatflt.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Fat_Flt);
+
+ -- Note the only entity from this package that is acccessed 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 Fat_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 00000000000..7fb8160c691
--- /dev/null
+++ b/gcc/ada/s-fatgen.adb
@@ -0,0 +1,836 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ G E N --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.19 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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; use Ada;
+with System;
+package body System.Fat_Gen is
+
+ Float_Radix : constant T := T (T'Machine_Radix);
+ Float_Radix_Inv : constant T := 1.0 / Float_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
+
+ 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;
+
+ 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 : T := T'Machine (XX);
+
+ begin
+ if X = 0.0 then
+ Frac := X;
+ Expo := 0;
+
+ -- More useful would be defining Expo to be T'Machine_Emin - 1 or
+ -- T'Machine_Emin - T'Machine_Mantissa, which would preserve
+ -- monotonicity of the exponent fuction ???
+
+ -- 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;
+
+ if X > 0.0 then
+ Frac := Ax;
+ else
+ Frac := -Ax;
+ end if;
+
+ Expo := Ex;
+ end;
+ end if;
+ end Decompose;
+
+ --------------
+ -- Exponent --
+ --------------
+
+ function Exponent (X : T) return UI is
+ X_Frac : T;
+ X_Exp : UI;
+
+ 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;
+
+ 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 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;
+
+ 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;
+
+ -----------
+ -- 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.
+
+ if X_Frac = 0.5 and then X > 0.0 then
+ return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
+
+ -- Otherwise the exponent stays the same
+
+ 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;
+ Arg_Frac : T;
+ P_Frac : T;
+ Sign_X : T;
+ IEEE_Rem : T;
+ Arg_Exp : UI;
+ P_Exp : UI;
+ K : UI;
+ P_Even : Boolean;
+
+ begin
+ 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.
+
+ if X_Frac = 0.5 and then X < 0.0 then
+ return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
+
+ -- Otherwise the exponent stays the same
+
+ 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 --
+ -----------
+
+ function Valid (X : 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.
+
+ -- 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**32;
+ type Rep_Index is range 0 .. 7;
+
+ Rep_Last : constant Rep_Index := (T'Size - 1) / Float_Word'Size;
+
+ type Float_Rep is array (Rep_Index range 0 .. Rep_Last) of Float_Word;
+
+ 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 (T'Size /= 96) +
+ Boolean'Pos (T'Size = 96);
+ -- 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 0 for x86 double extended
+ -- as GCC adds 16 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 + 1
+ -- contains 2**N values, for some N in Natural.
+
+ function To_Float is new Unchecked_Conversion (Float_Rep, T);
+
+ type Float_Access is access all T;
+ function To_Address is
+ new 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 only invalid numbers
+ -- are overflows and NaN's, both with exponent = Emax + 1.
+
+ return E /= IEEE_Emax + 1;
+
+ end if;
+
+ -- All denormalized numbers except 0.0 are invalid
+
+ -- Set exponent of X to zero, so we end up with the significand, which
+ -- definitely is a valid number and can be converted back to a float.
+
+ SR := R;
+ SR (Most_Significant_Word) :=
+ (SR (Most_Significant_Word)
+ and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor;
+
+ return (E in IEEE_Emin .. IEEE_Emax) or else
+ ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0);
+ end Valid;
+
+end System.Fat_Gen;
diff --git a/gcc/ada/s-fatgen.ads b/gcc/ada/s-fatgen.ads
new file mode 100644
index 00000000000..0ad0d682216
--- /dev/null
+++ b/gcc/ada/s-fatgen.ads
@@ -0,0 +1,101 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ G E N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Fat_Gen);
+
+ 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 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 : access T) return Boolean;
+ -- The argument must be passed by reference here, as T may be
+ -- an abnormal value that can be passed in a floating point register.
+
+private
+ pragma Inline (Machine);
+ pragma Inline (Model);
+ pragma Inline_Always (Valid);
+
+end System.Fat_Gen;
diff --git a/gcc/ada/s-fatlfl.ads b/gcc/ada/s-fatlfl.ads
new file mode 100644
index 00000000000..a16a26fbe91
--- /dev/null
+++ b/gcc/ada/s-fatlfl.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ L F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Fat_LFlt);
+
+ -- Note the only entity from this package that is acccessed 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 Fat_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 00000000000..3d4953dff46
--- /dev/null
+++ b/gcc/ada/s-fatllf.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ L L F --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Fat_LLF);
+
+ -- Note the only entity from this package that is acccessed 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 Fat_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 00000000000..bc17fbd6647
--- /dev/null
+++ b/gcc/ada/s-fatsfl.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ S F L T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Fat_SFlt);
+
+ -- Note the only entity from this package that is acccessed 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 Fat_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 00000000000..61451f4c538
--- /dev/null
+++ b/gcc/ada/s-ficobl.ads
@@ -0,0 +1,160 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+
+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);
+ -- 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;
+ 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.
+
+ 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 : 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 : 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 00000000000..21548568a33
--- /dev/null
+++ b/gcc/ada/s-fileio.adb
@@ -0,0 +1,1041 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F I L E _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.59 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization; use Ada.Finalization;
+with Ada.IO_Exceptions; use Ada.IO_Exceptions;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.Soft_Links;
+with Unchecked_Deallocation;
+
+package body System.File_IO is
+
+ use System.File_Control_Block;
+
+ package SSL renames System.Soft_Links;
+
+ ----------------------
+ -- 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 .. L_tmpnam + 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 Controlled with null record;
+ -- The closing of all open files and deletion of temporary files is an
+ -- action which takes place at the end of execution of the main program.
+ -- This action can be implemented using a library level object which
+ -- gets finalized at the end of the main program execution. The above is
+ -- a controlled type introduced for this purpose.
+
+ 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;
+ -- 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;
+ pragma Import
+ (C, text_translation_required, "__gnat_text_translation_required");
+ -- If true, add appropriate suffix to control string for Open.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Free_String is new 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.
+
+ ----------------
+ -- 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;
+ 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
+ -- No exception handler needed, since we cannot get an exception.
+
+ SSL.Lock_Task.all;
+ 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;
+ end Chain_File;
+
+ ---------------------
+ -- Check_File_Open --
+ ---------------------
+
+ procedure Check_File_Open (File : AFCB_Ptr) is
+ begin
+ if File = null then
+ raise Status_Error;
+ 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;
+ elsif File.Mode > Inout_File then
+ raise Mode_Error;
+ 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;
+ elsif File.Mode = In_File then
+ raise Mode_Error;
+ end if;
+ end Check_Write_Status;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out AFCB_Ptr) is
+ Close_Status : int := 0;
+ Dup_Strm : Boolean := False;
+
+ begin
+ 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);
+ end if;
+ end if;
+
+ -- Dechain file from list of open files and then free the storage
+ -- Since this is a global data structure, we have to protect against
+ -- multiple tasks attempting to access this list.
+
+ -- Note that we do not use an exception handler to unlock here since
+ -- no exception can occur inside the lock/unlock pair.
+
+ begin
+ SSL.Lock_Task.all;
+
+ 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;
+
+ SSL.Unlock_Task.all;
+ end;
+
+ -- 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;
+ end if;
+ end Close;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (File : in out AFCB_Ptr) is
+ begin
+ Check_File_Open (File);
+
+ if not File.Is_Regular_File then
+ raise Use_Error;
+ end if;
+
+ declare
+ Filename : aliased constant String := File.Name.all;
+
+ begin
+ Close (File);
+
+ -- 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;
+ 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;
+
+ --------------
+ -- 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
+ Discard : int;
+ Fptr1 : AFCB_Ptr;
+ Fptr2 : AFCB_Ptr;
+
+ begin
+ -- 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);
+ 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;
+
+ end Finalize;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush (File : AFCB_Ptr) is
+ begin
+ Check_Write_Status (File);
+
+ if fflush (File.Stream) = 0 then
+ return;
+ else
+ raise Device_Error;
+ 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 ACVT tests insist on!
+
+ -- If text file translation is required, then either b or t is
+ -- added 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 not Creat then
+ Fopstr (1) := 'r';
+ Fopstr (2) := '+';
+ Fptr := 3;
+ else
+ Fopstr (1) := 'w';
+ Fptr := 2;
+ end if;
+
+ when Inout_File | Append_File =>
+ if Creat then
+ Fopstr (1) := 'w';
+ else
+ Fopstr (1) := 'r';
+ end if;
+
+ 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
+ if Text then
+ Fopstr (Fptr) := 't';
+ else
+ Fopstr (Fptr) := 'b';
+ end if;
+
+ Fptr := Fptr + 1;
+ end if;
+
+ Fopstr (Fptr) := ASCII.NUL;
+ end Fopen_Mode;
+
+ ----------
+ -- Form --
+ ----------
+
+ function Form (File : in AFCB_Ptr) return String is
+ begin
+ if File = null then
+ raise Status_Error;
+ 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;
+
+ 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;
+ 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;
+ else
+ V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
+ end if;
+
+ if V > 999_999 then
+ raise Use_Error;
+ 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;
+
+ -- Start of processing for Form_Parameter
+
+ 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 : in AFCB_Ptr) return Boolean is
+ begin
+ return (File /= null);
+ end Is_Open;
+
+ -------------------
+ -- Make_Buffered --
+ -------------------
+
+ procedure Make_Buffered
+ (File : AFCB_Ptr;
+ Buf_Siz : Interfaces.C_Streams.size_t) is
+ status : Integer;
+
+ 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;
+
+ begin
+ status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
+ end Make_Line_Buffered;
+
+ ---------------------
+ -- Make_Unbuffered --
+ ---------------------
+
+ procedure Make_Unbuffered (File : AFCB_Ptr) is
+ status : Integer;
+
+ begin
+ status := setvbuf (File.Stream, Null_Address, IONBF, 0);
+ end Make_Unbuffered;
+
+ ----------
+ -- Mode --
+ ----------
+
+ function Mode (File : in AFCB_Ptr) return File_Mode is
+ begin
+ if File = null then
+ raise Status_Error;
+ else
+ return File.Mode;
+ end if;
+ end Mode;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name (File : in AFCB_Ptr) return String is
+ begin
+ if File = null then
+ raise Status_Error;
+ 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 : in out AFCB'Class;
+ Mode : File_Mode;
+ Name : String;
+ Form : String;
+ Amethod : Character;
+ Creat : Boolean;
+ Text : Boolean;
+ C_Stream : FILEs := NULL_Stream)
+ is
+ 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
+
+ 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
+
+ begin
+ if File_Ptr /= null then
+ raise Status_Error;
+ 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;
+ end if;
+ end;
+
+ -- If we were given a stream (call from xxx.C_Streams.Open), then set
+ -- full name to null and that is all we have to do in this case so
+ -- skip to end of processing.
+
+ if Stream /= NULL_Stream then
+ Fullname (1) := ASCII.Nul;
+ Full_Name_Len := 1;
+
+ -- 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;
+ end if;
+
+ Tmp_Name (Namestr'Address);
+
+ if Namestr (1) = ASCII.NUL then
+ raise Use_Error;
+ 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
+ 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;
+ end if;
+
+ for J in Fullname'Range loop
+ if Fullname (J) = ASCII.NUL then
+ Full_Name_Len := J;
+ exit;
+ end if;
+ end loop;
+
+ -- 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
+ 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;
+
+ -- 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 in either
+ -- case we just keep going on the search.
+
+ else
+ null;
+ end if;
+ end if;
+
+ P := P.Next;
+ end loop;
+ end;
+ end if;
+
+ -- Open specified file if we did not find an existing stream
+
+ if Stream = NULL_Stream then
+ Fopen_Mode (Mode, Text, 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 Creat = False and then Fopstr (1) /= 'r' then
+ if file_exists (Namestr'Address) = 0 then
+ raise Name_Error;
+ 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);
+
+ if Stream = NULL_Stream then
+ if file_exists (Namestr'Address) = 0 then
+ raise Name_Error;
+ else
+ raise Use_Error;
+ end if;
+ 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 := Text;
+ 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;
+
+ Chain_File (File_Ptr);
+ Append_Set (File_Ptr);
+ end Open;
+
+ --------------
+ -- 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;
+
+ elsif Nread = 0 then
+ raise End_Error;
+
+ else -- 0 < Nread < Siz
+ raise Data_Error;
+ end if;
+
+ end Read_Buf;
+
+ procedure Read_Buf
+ (File : AFCB_Ptr;
+ Buf : Address;
+ Siz : in 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;
+ end if;
+ end Read_Buf;
+
+ -----------
+ -- Reset --
+ -----------
+
+ -- The reset which does not change the mode simply does a rewind.
+
+ procedure Reset (File : in out AFCB_Ptr) is
+ begin
+ Check_File_Open (File);
+ Reset (File, 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 : in out AFCB_Ptr; Mode : in File_Mode) is
+ 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.
+
+ if File.Shared_Status = Yes
+ or else File.Name'Length <= 1
+ or else File.Is_System_File
+ or else (not File.Is_Regular_File)
+ then
+ raise Use_Error;
+
+ -- 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.
+
+ elsif Mode = File.Mode
+ and then Mode <= Inout_File
+ 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);
+
+ if File.Stream = NULL_Stream then
+ Close (File);
+ 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;
+ 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 00000000000..fbf3fe17edc
--- /dev/null
+++ b/gcc/ada/s-fileio.ads
@@ -0,0 +1,258 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F I L E _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.17 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 : in out 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, but otherwise is not used by this or any other
+ -- routine in this unit (except Form which retrieves the original value)
+ --
+ -- Amethod indicates the access method
+ --
+ -- D = Direct_IO
+ -- Q = Sequential_IO
+ -- S = Stream_IO
+ -- T = Text_IO
+ -- W = 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 : in out 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 to null.
+
+ procedure Delete (File : in out FCB.AFCB_Ptr);
+ -- The indicated file is unlinked
+
+ procedure Reset (File : in out FCB.AFCB_Ptr; Mode : in FCB.File_Mode);
+ -- The file is reset, and the mode changed as indicated.
+
+ procedure Reset (File : in out FCB.AFCB_Ptr);
+ -- The files is reset, and the mode is unchanged
+
+ function Mode (File : in FCB.AFCB_Ptr) return FCB.File_Mode;
+ -- Returns the mode as supplied by create, open or reset
+
+ function Name (File : in 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 : in 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 : in 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 spcial 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_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 ensure 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 : in 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 (Form);
+ pragma Inline (Mode);
+
+end System.File_IO;
diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb
new file mode 100644
index 00000000000..60df91c6dd1
--- /dev/null
+++ b/gcc/ada/s-finimp.adb
@@ -0,0 +1,582 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.48 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+with Ada.Tags;
+with Ada.Unchecked_Conversion;
+with System.Storage_Elements;
+with System.Soft_Links;
+
+package body System.Finalization_Implementation is
+
+ use Ada.Exceptions;
+ use System.Finalization_Root;
+
+ package SSL renames System.Soft_Links;
+
+ package SSE renames System.Storage_Elements;
+ use type SSE.Storage_Offset;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function To_Finalizable_Ptr is
+ new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
+
+ function To_Addr is
+ new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
+
+ type RC_Ptr is access all Record_Controller;
+
+ function To_RC_Ptr is
+ new Ada.Unchecked_Conversion (Address, RC_Ptr);
+
+ procedure Raise_Exception_No_Defer
+ (E : in Exception_Id;
+ Message : in String := "");
+ pragma Import (Ada, Raise_Exception_No_Defer,
+ "ada__exceptions__raise_exception_no_defer");
+ pragma No_Return (Raise_Exception_No_Defer);
+ -- Raise an exception without deferring abort. Note that we have to
+ -- use this rather kludgy Ada Import interface, since this subprogram
+ -- is not available in the visible spec of Ada.Exceptions.
+
+ 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) return SSE.Storage_Count;
+ pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
+
+ function Get_RC_Dynamically (Obj : Address) return Address;
+ -- Given an the address of an object (obj) of a tagged extension with
+ -- controlled component, computes the address of the record controller
+ -- located just after the _parent field
+
+ -------------
+ -- Adjust --
+ -------------
+
+ 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);
+ -- Substract the offset to the pointer
+
+ procedure Reverse_Adjust (P : Finalizable_Ptr);
+ -- Ajust 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)
+
+ 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;
+
+ 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 addresss 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: attachement 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. Attachement is
+ -- protected against multi-threaded access.
+
+ elsif Nb_Link = 2 then
+
+ 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;
+
+ -- Attachement 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;
+ end if;
+
+ end Attach_To_Final_List;
+
+ ---------------------
+ -- Deep_Tag_Adjust --
+ ---------------------
+
+ procedure Deep_Tag_Adjust
+ (L : in out SFR.Finalizable_Ptr;
+ A : System.Address;
+ B : Short_Short_Integer)
+ is
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
+
+ Controller : RC_Ptr;
+
+ begin
+ -- Has controlled components
+
+ if Offset /= 0 then
+ if Offset > 0 then
+ Controller := To_RC_Ptr (A + Offset);
+ else
+ Controller := To_RC_Ptr (Get_RC_Dynamically (A));
+ end if;
+
+ Adjust (Controller.all);
+ Attach_To_Final_List (L, Controller.all, B);
+
+ -- Is controlled
+
+ elsif V.all in Finalizable then
+ Adjust (V.all);
+ Attach_To_Final_List (L, Finalizable (V.all), 1);
+ end if;
+ end Deep_Tag_Adjust;
+
+ ---------------------
+ -- 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);
+ Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
+
+ Controller : RC_Ptr;
+
+ begin
+ if Offset /= 0 then
+ if Offset > 0 then
+ Controller := To_RC_Ptr (A + Offset);
+ else
+ Controller := To_RC_Ptr (Get_RC_Dynamically (A));
+ end if;
+
+ Attach_To_Final_List (L, Controller.all, B);
+
+ -- Is controlled
+
+ elsif V.all in Finalizable then
+ Attach_To_Final_List (L, V.all, B);
+ end if;
+ end Deep_Tag_Attach;
+
+ -----------------------
+ -- Deep_Tag_Finalize --
+ -----------------------
+
+ procedure Deep_Tag_Finalize
+ (L : in out SFR.Finalizable_Ptr;
+ A : System.Address;
+ B : Boolean)
+ is
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
+
+ Controller : RC_Ptr;
+
+ begin
+ -- Has controlled components
+
+ if Offset /= 0 then
+ if Offset > 0 then
+ Controller := To_RC_Ptr (A + Offset);
+ else
+ Controller := To_RC_Ptr (Get_RC_Dynamically (A));
+ end if;
+
+ if B then
+ Finalize_One (Controller.all);
+ else
+ Finalize (Controller.all);
+ end if;
+
+ -- Is controlled
+
+ elsif V.all in Finalizable then
+ if B then
+ Finalize_One (V.all);
+ else
+ Finalize (V.all);
+ end if;
+ end if;
+ end Deep_Tag_Finalize;
+
+ -------------------------
+ -- Deep_Tag_Initialize --
+ -------------------------
+
+ procedure Deep_Tag_Initialize
+ (L : in out SFR.Finalizable_Ptr;
+ A : System.Address;
+ B : Short_Short_Integer)
+ is
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
+
+ Controller : RC_Ptr;
+
+ begin
+ -- This procedure should not be called if the object has no
+ -- controlled components
+
+ if Offset = 0 then
+
+ raise Program_Error;
+
+ -- Has controlled components
+
+ else
+ if Offset > 0 then
+ Controller := To_RC_Ptr (A + Offset);
+ else
+ Controller := To_RC_Ptr (Get_RC_Dynamically (A));
+ end if;
+ end if;
+
+ Initialize (Controller.all);
+ Attach_To_Final_List (L, Controller.all, B);
+
+ -- Is controlled
+
+ if V.all in Finalizable then
+ Initialize (V.all);
+ Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1);
+ end if;
+ end Deep_Tag_Initialize;
+
+ -----------------------------
+ -- Detach_From_Final_List --
+ -----------------------------
+
+ -- We know that the detach object is neither at the beginning nor at the
+ -- end of the list, thank's 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.
+
+ if Obj.Next /= null and then Obj.Prev /= null then
+ SSL.Lock_Task.all;
+ Obj.Next.Prev := Obj.Prev;
+ Obj.Prev.Next := Obj.Next;
+ SSL.Unlock_Task.all;
+ end if;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
+ end Detach_From_Final_List;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ 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 abortion
+ -- 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 abortion, 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_Occurence is record
+ Id : Exception_Id;
+ end record;
+ type Ptr is access all Fake_Exception_Occurence;
+
+ -- Let's get the current exception before starting to finalize in
+ -- order to check if we are in the abort case if an exception is
+ -- raised.
+
+ function To_Ptr is new
+ Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
+ X : Exception_Id :=
+ To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
+
+ begin
+ 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_RC_Dynamically --
+ ------------------------
+
+ function Get_RC_Dynamically (Obj : Address) return Address is
+
+ -- 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 := Storage_Unit - 1;
+
+ type Faked_Type_Of_Obj is record
+ Parent : SSE.Storage_Array
+ (1 .. (Parent_Size (Obj) + D) / Storage_Unit);
+ 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_Obj_Ptr (Obj).Controller'Address;
+ end Get_RC_Dynamically;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Limited_Record_Controller) is
+ begin
+ null;
+ end Initialize;
+
+ procedure Initialize (Object : in out Record_Controller) is
+ begin
+ Object.My_Address := Object'Address;
+ end Initialize;
+
+ -------------------------
+ -- Raise_From_Finalize --
+ -------------------------
+
+ procedure Raise_From_Finalize
+ (L : Finalizable_Ptr;
+ From_Abort : Boolean;
+ E_Occ : Exception_Occurrence)
+ is
+ Msg : constant String := Exception_Message (E_Occ);
+ 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 finalization from an Abort, then nothing to do
+
+ if From_Abort then
+ null;
+
+ -- If no message, then add our own message saying what happened
+
+ elsif Msg = "" then
+ Raise_Exception_No_Defer
+ (E => Program_Error'Identity,
+ Message => "exception " &
+ Exception_Name (E_Occ) &
+ " raised during finalization");
+
+ -- If there was a message, pass it on
+
+ else
+ Raise_Exception_No_Defer (Program_Error'Identity, Msg);
+ end if;
+ end Raise_From_Finalize;
+
+-- Initialization of package, set Adafinal soft link
+
+begin
+ SSL.Adafinal := 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 00000000000..49db440a0ec
--- /dev/null
+++ b/gcc/ada/s-finimp.ads
@@ -0,0 +1,151 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.31 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Finalization_Root;
+
+package System.Finalization_Implementation is
+pragma Elaborate_Body (Finalization_Implementation);
+
+ package SFR renames System.Finalization_Root;
+
+ ------------------------------------------------
+ -- Finalization Management Abstract Interface --
+ ------------------------------------------------
+
+ 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 can be either 0 for no
+ -- attachement, 1 for simple linked lists or 2 for doubly linked lists
+ -- or even 3 for a simple attachement of a whole array of elements.
+ -- Attachement to a simply linked list is not protected against
+ -- concurrent access and should only be used in context 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)
+
+ 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_Initialize
+ (L : in out SFR.Finalizable_Ptr;
+ A : System.Address;
+ B : Short_Short_Integer);
+ -- Generic initialize 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 attachement level (see Attach_To_Final_List)
+
+ procedure Deep_Tag_Adjust
+ (L : in out SFR.Finalizable_Ptr;
+ A : System.Address;
+ B : Short_Short_Integer);
+ -- Generic adjust 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 attachement level (see Attach_To_Final_List)
+
+ procedure Deep_Tag_Finalize
+ (L : in out SFR.Finalizable_Ptr;
+ A : System.Address;
+ B : Boolean);
+ -- Generic finalize 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 attachement level (see Attach_To_Final_List)
+
+ procedure Deep_Tag_Attach
+ (L : in out SFR.Finalizable_Ptr;
+ A : System.Address;
+ B : Short_Short_Integer);
+ -- Generic attachement 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 attachement 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;
+
+ procedure Initialize (Object : in out Limited_Record_Controller);
+ -- Does nothing
+
+ 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;
+
+ procedure Initialize (Object : in out Record_Controller);
+ -- Initialize the field My_Address to the Object'Address
+
+ procedure Adjust (Object : in out Record_Controller);
+ -- Adjust the components and their finalization pointers by substracting
+ -- 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 00000000000..fba98865ab3
--- /dev/null
+++ b/gcc/ada/s-finroo.adb
@@ -0,0 +1,99 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+
+ ----------
+ -- Read --
+ ----------
+
+ -- Read and Write must be empty in order to avoid copying the
+ -- finalization pointers.
+
+ pragma Warnings (Off);
+ -- Suppress warning for out paramater Item which is not assigned
+ -- because it is pretty much empty.
+
+ procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out Root_Controlled)
+ is
+ begin
+ null;
+ end Read;
+
+ -----------
+ -- Write --
+ -----------
+
+ -- Read and Write must be empty in order to avoid copying the
+ -- finalization pointers.
+
+ procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ Item : in Root_Controlled)
+ is
+ begin
+ null;
+ end Write;
+
+end System.Finalization_Root;
diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads
new file mode 100644
index 00000000000..d853cf4e2b5
--- /dev/null
+++ b/gcc/ada/s-finroo.ads
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+with Ada.Streams;
+package System.Finalization_Root is
+pragma Preelaborate (Finalization_Root);
+
+ type Root_Controlled;
+
+ type Finalizable_Ptr is access all Root_Controlled'Class;
+
+ 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);
+
+ procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ Item : in Root_Controlled);
+ procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out Root_Controlled);
+
+ for Root_Controlled'Read use Read;
+ for Root_Controlled'Write use Write;
+end System.Finalization_Root;
diff --git a/gcc/ada/s-fore.adb b/gcc/ada/s-fore.adb
new file mode 100644
index 00000000000..b5d686ed0ae
--- /dev/null
+++ b/gcc/ada/s-fore.adb
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..8f95d40481b
--- /dev/null
+++ b/gcc/ada/s-fore.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . F O R E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for the 'Fore attribute
+
+package System.Fore is
+pragma Pure (Fore);
+
+ 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-gloloc.adb b/gcc/ada/s-gloloc.adb
new file mode 100644
index 00000000000..73d69df1185
--- /dev/null
+++ b/gcc/ada/s-gloloc.adb
@@ -0,0 +1,162 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . G L O B A L _ L O C K S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Task_Lock;
+
+package body System.Global_Locks is
+
+ type String_Access is access String;
+
+ package TSL renames GNAT.Task_Lock;
+
+ 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 : in 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;
+
+ 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 00000000000..3129044bbf9
--- /dev/null
+++ b/gcc/ada/s-gloloc.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . G L O B A L _ L O C K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+ -- 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;
+
+ procedure Create_Lock
+ (Lock : out Lock_Type;
+ Name : in 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-imgbiu.adb b/gcc/ada/s-imgbiu.adb
new file mode 100644
index 00000000000..337a4c3baf4
--- /dev/null
+++ b/gcc/ada/s-imgbiu.adb
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ B I U --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..c01fe7b756c
--- /dev/null
+++ b/gcc/ada/s-imgbiu.ads
@@ -0,0 +1,76 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ B I U --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Img_BIU);
+
+ 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 00000000000..0ab8a3004bc
--- /dev/null
+++ b/gcc/ada/s-imgboo.adb
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ B O O L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Img_Bool is
+
+ -------------------
+ -- Image_Boolean --
+ -------------------
+
+ function Image_Boolean (V : Boolean) return String is
+ begin
+ if V then
+ return "TRUE";
+ else
+ return "FALSE";
+ 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 00000000000..30f03c6240c
--- /dev/null
+++ b/gcc/ada/s-imgboo.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ B O O L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Boolean'Image
+
+package System.Img_Bool is
+pragma Pure (Img_Bool);
+
+ function Image_Boolean (V : Boolean) return String;
+ -- Computes Boolean'Image (V) and returns the result.
+
+end System.Img_Bool;
diff --git a/gcc/ada/s-imgcha.adb b/gcc/ada/s-imgcha.adb
new file mode 100644
index 00000000000..aab81bc8b42
--- /dev/null
+++ b/gcc/ada/s-imgcha.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.11 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Img_Char is
+
+ ---------------------
+ -- Image_Character --
+ ---------------------
+
+ function Image_Character (V : Character) return String is
+ subtype Cname is String (1 .. 3);
+
+ S : Cname;
+
+ 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 := C0 (V);
+
+ if S (3) = ' ' then
+ return S (1 .. 2);
+ else
+ return S;
+ end if;
+
+ elsif V in C1_Range then
+ S := C1 (V);
+
+ if S (1) /= 'r' then
+ if S (3) = ' ' then
+ return S (1 .. 2);
+ else
+ return S;
+ end if;
+
+ -- 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);
+ St : String (1 .. 12) := "RESERVED_xxx";
+
+ begin
+ St (10) := Character'Val (48 + VP / 100);
+ St (11) := Character'Val (48 + (VP / 10) mod 10);
+ St (12) := Character'Val (48 + VP mod 10);
+ return St;
+ end;
+ end if;
+
+ -- Normal characters yield the character enlosed in quotes (RM 3.5(32))
+
+ else
+ S (1) := ''';
+ S (2) := V;
+ S (3) := ''';
+ return S;
+ end if;
+ end Image_Character;
+
+end System.Img_Char;
diff --git a/gcc/ada/s-imgcha.ads b/gcc/ada/s-imgcha.ads
new file mode 100644
index 00000000000..d4639cfd491
--- /dev/null
+++ b/gcc/ada/s-imgcha.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Character'Image
+
+package System.Img_Char is
+pragma Pure (Img_Char);
+
+ function Image_Character (V : Character) return String;
+ -- Computes Character'Image (V) and returns the result
+
+
+end System.Img_Char;
diff --git a/gcc/ada/s-imgdec.adb b/gcc/ada/s-imgdec.adb
new file mode 100644
index 00000000000..0ac4a8bf1cd
--- /dev/null
+++ b/gcc/ada/s-imgdec.adb
@@ -0,0 +1,359 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.16 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Img_Int; use System.Img_Int;
+
+package body System.Img_Dec is
+
+ -------------------
+ -- Image_Decimal --
+ -------------------
+
+ function Image_Decimal
+ (V : Integer;
+ Scale : Integer)
+ return String
+ is
+ P : Natural := 0;
+ S : String (1 .. 64);
+
+ begin
+ Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
+
+ -- Mess around to make sure we have the objectionable space at the
+ -- start for positive numbers in accordance with the annoying rules!
+
+ if S (1) /= ' ' and then S (1) /= '-' then
+ S (2 .. P + 1) := S (1 .. P);
+ S (1) := ' ';
+ return S (1 .. P + 1);
+ else
+ return S (1 .. P);
+ end if;
+ 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 (1) = '-');
+ -- Set True if input is negative
+
+ Zero : Boolean := (Digs (2) = '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 : Natural);
+ -- 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.
+
+ 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
+
+ procedure Round (N : Natural) is
+ D : Character;
+
+ begin
+ -- Nothing to do if rounding at or past last digit
+
+ 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 (2) >= '5' then
+ Digs (1) := '1';
+ else
+ Digs (1) := '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 (1) := '1';
+ FD := 1;
+ ND := ND + 1;
+ Digits_Before_Point := Digits_Before_Point + 1;
+ end if;
+ end if;
+ end Round;
+
+ procedure Set (C : Character) is
+ begin
+ P := P + 1;
+ S (P) := C;
+ end Set;
+
+ 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;
+
+ procedure Set_Digits (S, E : Natural) is
+ begin
+ for J in S .. E loop
+ Set (Digs (J));
+ end loop;
+ end Set_Digits;
+
+ 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 (Aft + 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.
+
+ if Zero then
+ Expon := 0;
+ else
+ Expon := Digits_Before_Point - 1;
+ end if;
+
+ 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 ('.');
+
+ Set_Zeroes (Digits_After_Point - ND);
+ Set_Digits (FD, LD);
+
+ -- At least one digit before point in input
+
+ else
+ Set_Blanks_And_Sign (Fore - Digits_Before_Point);
+
+ -- Less digits in input than are needed before point
+ -- Input: 1PP Output: 100.000
+
+ if ND < Digits_Before_Point then
+ Set_Digits (FD, LD);
+ Set_Zeroes (Digits_Before_Point - ND);
+ Set ('.');
+ Set_Zeroes (Digits_After_Point);
+
+ -- Input has full amount of digits before decimal point
+
+ else
+ 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 : out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ Digs : String := Image_Integer (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 00000000000..19cc702ed2e
--- /dev/null
+++ b/gcc/ada/s-imgdec.ads
@@ -0,0 +1,83 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ D E C --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 Preelaborate (Img_Dec);
+
+ function Image_Decimal
+ (V : Integer;
+ Scale : Integer)
+ return String;
+ -- Compute 'Image of V, the integer value (in units of delta) of a decimal
+ -- type whose Scale is as given and return the result. THe image is given
+ -- by the rules in RM 3.5(34) for fixed-point type image functions.
+
+ procedure Set_Image_Decimal
+ (V : Integer;
+ S : 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.
+
+ 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 00000000000..24d0a29af5e
--- /dev/null
+++ b/gcc/ada/s-imgenu.adb
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with 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 Unchecked_Conversion (System.Address, Index_Table_Ptr);
+
+ IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+
+ Start : Natural := Natural (IndexesT (Pos));
+ Next : 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 Unchecked_Conversion (System.Address, Index_Table_Ptr);
+
+ IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+
+ Start : Natural := Natural (IndexesT (Pos));
+ Next : 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 Unchecked_Conversion (System.Address, Index_Table_Ptr);
+
+ IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+
+ Start : Natural := Natural (IndexesT (Pos));
+ Next : 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 00000000000..641fbeabf4e
--- /dev/null
+++ b/gcc/ada/s-imgenu.ads
@@ -0,0 +1,78 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 routines in these packages.
+
+package System.Img_Enum is
+pragma Pure (Img_Enum);
+
+ 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
+ -- 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 00000000000..445f11fdf06
--- /dev/null
+++ b/gcc/ada/s-imgint.adb
@@ -0,0 +1,98 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ I N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Img_Int is
+
+ -------------------
+ -- Image_Integer --
+ -------------------
+
+ function Image_Integer (V : Integer) return String is
+ P : Natural;
+ S : String (1 .. Integer'Width);
+
+ begin
+ if V >= 0 then
+ P := 1;
+ S (P) := ' ';
+ else
+ P := 0;
+ end if;
+
+ Set_Image_Integer (V, S, P);
+ return S (1 .. P);
+ end Image_Integer;
+
+ -----------------------
+ -- Set_Image_Integer --
+ -----------------------
+
+ procedure Set_Image_Integer
+ (V : Integer;
+ S : 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.
+
+ 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 00000000000..5804310d458
--- /dev/null
+++ b/gcc/ada/s-imgint.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.12 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Img_Int);
+
+ function Image_Integer (V : Integer) return String;
+ -- Computes Integer'Image (V) and returns the result
+
+ procedure Set_Image_Integer
+ (V : Integer;
+ S : out String;
+ P : in out Natural);
+ -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
+ -- Text_IO format where Width = 0), 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 be necessarily raised if this is violated since it is perfectly
+ -- valid to compile this unit with checks off).
+
+end System.Img_Int;
diff --git a/gcc/ada/s-imgllb.adb b/gcc/ada/s-imgllb.adb
new file mode 100644
index 00000000000..c4c419fc9fe
--- /dev/null
+++ b/gcc/ada/s-imgllb.adb
@@ -0,0 +1,161 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L B --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..5a83513c717
--- /dev/null
+++ b/gcc/ada/s-imgllb.ads
@@ -0,0 +1,76 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L B --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Img_LLB);
+
+ 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 00000000000..688c87c0770
--- /dev/null
+++ b/gcc/ada/s-imglld.adb
@@ -0,0 +1,89 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Img_Dec; use System.Img_Dec;
+with System.Img_LLI; use System.Img_LLI;
+
+package body System.Img_LLD is
+
+ -----------------------------
+ -- Image_Long_Long_Decimal --
+ -----------------------------
+
+ function Image_Long_Long_Decimal
+ (V : Long_Long_Integer;
+ Scale : Integer)
+ return String
+ is
+ P : Natural := 0;
+ S : String (1 .. 64);
+
+ begin
+ Set_Image_Long_Long_Decimal
+ (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
+
+ -- Mess around to make sure we have the objectionable space at the
+ -- start for positive numbers in accordance with the annoying rules!
+
+ if S (1) /= ' ' and then S (1) /= '-' then
+ S (2 .. P + 1) := S (1 .. P);
+ S (1) := ' ';
+ return S (1 .. P + 1);
+ else
+ return S (1 .. P);
+ end if;
+ end Image_Long_Long_Decimal;
+
+ ---------------------------------
+ -- Set_Image_Long_Long_Decimal --
+ ---------------------------------
+
+ procedure Set_Image_Long_Long_Decimal
+ (V : Long_Long_Integer;
+ S : out String;
+ P : in out Natural;
+ Scale : Integer;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ Digs : String := Image_Long_Long_Integer (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 00000000000..0582e07c2d0
--- /dev/null
+++ b/gcc/ada/s-imglld.ads
@@ -0,0 +1,67 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L D --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 Preelaborate (Img_LLD);
+
+ function Image_Long_Long_Decimal
+ (V : Long_Long_Integer;
+ Scale : Integer)
+ return String;
+ -- Compute 'Image of V, the integer value (in units of delta) of a decimal
+ -- type whose Scale is as given and returns the result. The image is given
+ -- by the rules in RM 3.5(34) for fixed-point type image functions.
+
+ procedure Set_Image_Long_Long_Decimal
+ (V : Long_Long_Integer;
+ S : 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.
+
+end System.Img_LLD;
diff --git a/gcc/ada/s-imglli.adb b/gcc/ada/s-imglli.adb
new file mode 100644
index 00000000000..571110c6735
--- /dev/null
+++ b/gcc/ada/s-imglli.adb
@@ -0,0 +1,99 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L I --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.12 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Img_LLI is
+
+ -----------------------------
+ -- Image_Long_Long_Integer --
+ -----------------------------
+
+ function Image_Long_Long_Integer (V : Long_Long_Integer) return String is
+ P : Natural;
+ S : String (1 .. Long_Long_Integer'Width);
+
+ begin
+ if V >= 0 then
+ P := 1;
+ S (P) := ' ';
+ else
+ P := 0;
+ end if;
+
+ Set_Image_Long_Long_Integer (V, S, P);
+ return S (1 .. P);
+ end Image_Long_Long_Integer;
+
+ ---------------------------------
+ -- Set_Image_Long_Long_Integer --
+ ---------------------------------
+
+ procedure Set_Image_Long_Long_Integer
+ (V : Long_Long_Integer;
+ S : 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.
+
+ 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 00000000000..b927c635a10
--- /dev/null
+++ b/gcc/ada/s-imglli.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 Preelaborate (Img_LLI);
+
+ function Image_Long_Long_Integer (V : Long_Long_Integer) return String;
+ -- Computes Long_Long_Integer'Image (V) and returns the result.
+
+ procedure Set_Image_Long_Long_Integer
+ (V : Long_Long_Integer;
+ S : out String;
+ P : in out Natural);
+ -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
+ -- Text_IO format where Width = 0), 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 be necessarily raised if this is violated since it is perfectly
+ -- valid to compile this unit with checks off).
+
+end System.Img_LLI;
diff --git a/gcc/ada/s-imgllu.adb b/gcc/ada/s-imgllu.adb
new file mode 100644
index 00000000000..e5d1d487a87
--- /dev/null
+++ b/gcc/ada/s-imgllu.adb
@@ -0,0 +1,90 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L U --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+
+package body System.Img_LLU is
+
+ ------------------------------
+ -- Image_Long_Long_Unsigned --
+ ------------------------------
+
+ function Image_Long_Long_Unsigned
+ (V : Long_Long_Unsigned)
+ return String
+ is
+ P : Natural;
+ S : String (1 .. Long_Long_Unsigned'Width);
+
+ begin
+ P := 1;
+ S (P) := ' ';
+ Set_Image_Long_Long_Unsigned (V, S, P);
+ return S (1 .. P);
+ end Image_Long_Long_Unsigned;
+
+ -----------------------
+ -- Set_Image_Long_Long_Unsigned --
+ -----------------------
+
+ procedure Set_Image_Long_Long_Unsigned
+ (V : Long_Long_Unsigned;
+ S : out String;
+ P : in out Natural)
+ is
+ 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 (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 00000000000..fed63e50c52
--- /dev/null
+++ b/gcc/ada/s-imgllu.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L U --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Img_LLU);
+
+ function Image_Long_Long_Unsigned
+ (V : System.Unsigned_Types.Long_Long_Unsigned)
+ return String;
+ -- Computes Long_Long_Unsigned'Image (V) and returns the result.
+
+ procedure Set_Image_Long_Long_Unsigned
+ (V : System.Unsigned_Types.Long_Long_Unsigned;
+ S : out String;
+ P : in out Natural);
+ -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
+ -- Text_IO format where Width = 0), 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 be necessarily raised if this is violated since it is perfectly
+ -- valid to compile this unit with checks off).
+
+end System.Img_LLU;
diff --git a/gcc/ada/s-imgllw.adb b/gcc/ada/s-imgllw.adb
new file mode 100644
index 00000000000..89796022854
--- /dev/null
+++ b/gcc/ada/s-imgllw.adb
@@ -0,0 +1,140 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L W --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..23ebfd04d09
--- /dev/null
+++ b/gcc/ada/s-imgllw.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L W --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Img_LLW);
+
+ 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 00000000000..c5fdd76cbd9
--- /dev/null
+++ b/gcc/ada/s-imgrea.adb
@@ -0,0 +1,674 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ R E A L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.45 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 --
+ --------------------------
+
+ function Image_Floating_Point
+ (V : Long_Long_Float;
+ Digs : Natural)
+ return String
+ is
+ P : Natural := 0;
+ S : String (1 .. Long_Long_Float'Width);
+
+ begin
+ if not Is_Negative (V) then
+ S (1) := ' ';
+ P := 1;
+ end if;
+
+ Set_Image_Real (V, S, P, 1, Digs - 1, 3);
+ return S (1 .. P);
+ end Image_Floating_Point;
+
+ --------------------------------
+ -- Image_Ordinary_Fixed_Point --
+ --------------------------------
+
+ function Image_Ordinary_Fixed_Point
+ (V : Long_Long_Float;
+ Aft : Natural)
+ return String
+ is
+ P : Natural := 0;
+ S : String (1 .. Long_Long_Float'Width);
+
+ begin
+ if V >= 0.0 then
+ S (1) := ' ';
+ P := 1;
+ end if;
+
+ Set_Image_Real (V, S, P, 1, Aft, 0);
+ return S (1 .. P);
+ 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 accomodate 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 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 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;
+
+ -- 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;
+ end if;
+
+ -- Deal with invalid values
+
+ if not X'Valid then
+
+ -- Note that we're taking our chances here, as X 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 X > Long_Long_Float'Last then
+ Set (Sign);
+ Set ('I');
+ Set ('n');
+ Set ('f');
+ Set_Special_Fill (4);
+
+ -- In all other cases we print NaN
+
+ else
+ Set ('N');
+ Set ('a');
+ Set ('N');
+ Set_Special_Fill (3);
+ end if;
+
+ return;
+
+ -- Case of non-zero value with Exp = 0
+
+ elsif 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 00000000000..234577b965a
--- /dev/null
+++ b/gcc/ada/s-imgrea.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ R E A L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Image for fixed and float types (also used for Float_IO/Fixed_IO output)
+
+package System.Img_Real is
+pragma Preelaborate (Img_Real);
+
+ function Image_Ordinary_Fixed_Point
+ (V : Long_Long_Float;
+ Aft : Natural)
+ return String;
+ -- Computes the image of V and returns the result 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).
+
+ function Image_Floating_Point
+ (V : Long_Long_Float;
+ Digs : Natural)
+ return String;
+ -- Computes the image of V and returns the result according to the rules
+ -- for image for foating-point types (RM 3.5(33)), where Digs is the value
+ -- of the Digits attribute for the floating-point type.
+
+ 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.
+
+end System.Img_Real;
diff --git a/gcc/ada/s-imguns.adb b/gcc/ada/s-imguns.adb
new file mode 100644
index 00000000000..2f4451df041
--- /dev/null
+++ b/gcc/ada/s-imguns.adb
@@ -0,0 +1,90 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ U N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+
+package body System.Img_Uns is
+
+ --------------------
+ -- Image_Unsigned --
+ --------------------
+
+ function Image_Unsigned
+ (V : Unsigned)
+ return String
+ is
+ P : Natural;
+ S : String (1 .. Unsigned'Width);
+
+ begin
+ P := 1;
+ S (P) := ' ';
+ Set_Image_Unsigned (V, S, P);
+ return S (1 .. P);
+ end Image_Unsigned;
+
+ ------------------------
+ -- Set_Image_Unsigned --
+ ------------------------
+
+ procedure Set_Image_Unsigned
+ (V : Unsigned;
+ S : out String;
+ P : in out Natural)
+ is
+ procedure Set_Digits (T : Unsigned);
+ -- Set decimal digits of 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 (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 00000000000..073e44e69d1
--- /dev/null
+++ b/gcc/ada/s-imguns.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ U N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Img_Uns);
+
+ function Image_Unsigned
+ (V : System.Unsigned_Types.Unsigned)
+ return String;
+ -- Computes Unsigned'Image (V) and returns the result.
+
+ procedure Set_Image_Unsigned
+ (V : System.Unsigned_Types.Unsigned;
+ S : out String;
+ P : in out Natural);
+ -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
+ -- Text_IO format where Width = 0), 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 be necessarily raised if this is violated since it is perfectly
+ -- valid to compile this unit with checks off).
+
+end System.Img_Uns;
diff --git a/gcc/ada/s-imgwch.adb b/gcc/ada/s-imgwch.adb
new file mode 100644
index 00000000000..487889b5d07
--- /dev/null
+++ b/gcc/ada/s-imgwch.adb
@@ -0,0 +1,87 @@
+-----------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ W C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.15 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Img_Char; use System.Img_Char;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_WtS; use System.WCh_WtS;
+
+package body System.Img_WChar is
+
+ --------------------------
+ -- Image_Wide_Character --
+ --------------------------
+
+ function Image_Wide_Character
+ (V : Wide_Character;
+ EM : WC_Encoding_Method)
+ return String
+ is
+ Val : constant Natural := Wide_Character'Pos (V);
+ WS : Wide_String (1 .. 3);
+
+ begin
+ -- If in range of standard character, use standard character routine
+
+ if Val < 16#80#
+ or else (Val <= 16#FF#
+ and then EM not in WC_Upper_Half_Encoding_Method)
+ then
+ return Image_Character (Character'Val (Val));
+
+ -- if the value is one of the last two characters in the type, use
+ -- their language-defined names (3.5.2(3)).
+
+ elsif Val = 16#FFFE# then
+ return "FFFE";
+
+ elsif Val = 16#FFFF# then
+ return "FFFF";
+
+ -- Otherwise return an appropriate escape sequence (i.e. one matching
+ -- the convention implemented by Scn.Wide_Char). The easiest thing is
+ -- to build a wide string for the result, and then use the Wide_Value
+ -- function to build the resulting String.
+
+ else
+ WS (1) := ''';
+ WS (2) := V;
+ WS (3) := ''';
+
+ return Wide_String_To_String (WS, EM);
+ end if;
+
+ end Image_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 00000000000..693d1fc91e0
--- /dev/null
+++ b/gcc/ada/s-imgwch.ads
@@ -0,0 +1,53 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ W C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Wide_Character'Image
+
+with System.WCh_Con;
+
+package System.Img_WChar is
+pragma Pure (Img_WChar);
+
+ function Image_Wide_Character
+ (V : Wide_Character;
+ EM : System.WCh_Con.WC_Encoding_Method)
+ return String;
+ -- Computes Wode_Character'Image (V) and returns the computed result,
+ -- The argument EM is a constant representing the encoding method in use.
+ -- The encoding method used is guaranteed to be consistent across a
+ -- given program execution and to correspond to the method used in the
+ -- source programs.
+
+end System.Img_WChar;
diff --git a/gcc/ada/s-imgwiu.adb b/gcc/ada/s-imgwiu.adb
new file mode 100644
index 00000000000..7c1c847f314
--- /dev/null
+++ b/gcc/ada/s-imgwiu.adb
@@ -0,0 +1,138 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ W I U --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..5a9d2f465e2
--- /dev/null
+++ b/gcc/ada/s-imgwiu.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ W I U --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Img_WIU);
+
+ 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.ads b/gcc/ada/s-inmaop.ads
new file mode 100644
index 00000000000..173c169331b
--- /dev/null
+++ b/gcc/ada/s-inmaop.ads
@@ -0,0 +1,122 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- O P E R A T I O N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System.Interrupt_Management.Operations is
+
+ procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID);
+ -- Mask the calling thread for the interrupt
+ pragma Inline (Thread_Block_Interrupt);
+
+ procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID);
+ -- Unmask the calling thread for the interrupt
+ pragma Inline (Thread_Unblock_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);
+ -- Set the interrupt mask of the calling thread while returning the
+ -- previous Mask.
+ pragma Inline (Set_Interrupt_Mask);
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask);
+ -- Get the interrupt mask of the calling thread
+ pragma Inline (Get_Interrupt_Mask);
+
+ function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID;
+ -- Wait for the interrupts specified in Mask and return
+ -- the interrupt received. Upon error it return 0.
+ pragma Inline (Interrupt_Wait);
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID);
+ -- Set the sigaction of the Interrupt to default (SIG_DFL).
+ pragma Inline (Install_Default_Action);
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID);
+ -- Set the sigaction of the Interrupt to ignore (SIG_IGN).
+ pragma Inline (Install_Ignore_Action);
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask);
+ -- Get a Interrupt_Mask with all the interrupt masked
+ pragma Inline (Fill_Interrupt_Mask);
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask);
+ -- Get a Interrupt_Mask with all the interrupt unmasked
+ pragma Inline (Empty_Interrupt_Mask);
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID);
+ -- Mask the given interrupt in the Interrupt_Mask
+ pragma Inline (Add_To_Interrupt_Mask);
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID);
+ -- Unmask the given interrupt in the Interrupt_Mask
+ pragma Inline (Delete_From_Interrupt_Mask);
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean;
+ -- See if a given interrupt is masked in the Interrupt_Mask
+ pragma Inline (Is_Member);
+
+ procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask);
+ -- Assigment needed for limited private type Interrupt_Mask.
+ pragma Inline (Copy_Interrupt_Mask);
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID);
+ -- raise an Interrupt process-level
+ pragma Inline (Interrupt_Self_Process);
+
+ -- The following objects serve as constants, but are initialized
+ -- in the body to aid portability. These actually belong to the
+ -- System.Interrupt_Management but since Interrupt_Mask is a
+ -- private type we can not have them declared there.
+
+ 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.adb b/gcc/ada/s-interr.adb
new file mode 100644
index 00000000000..03db2ff1512
--- /dev/null
+++ b/gcc/ada/s-interr.adb
@@ -0,0 +1,1572 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.36 $
+-- --
+-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 acheive 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.
+
+-- 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;
+-- used for Task_ID type
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+with System.Task_Primitives;
+-- used for RTS_Lock
+-- Self
+
+with System.Interrupt_Management;
+-- used for Reserve
+-- Interrupt_ID
+-- Interrupt_Mask
+-- Abort_Task_Interrupt
+
+with System.Interrupt_Management.Operations;
+-- used for Thread_Block_Interrupt
+-- Thread_Unblock_Interrupt
+-- Install_Default_Action
+-- Install_Ignore_Action
+-- Copy_Interrupt_Mask
+-- Set_Interrupt_Mask
+-- Empty_Interrupt_Mask
+-- Fill_Interrupt_Mask
+-- Add_To_Interrupt_Mask
+-- Delete_From_Interrupt_Mask
+-- Interrupt_Wait
+-- Interrupt_Self_Process
+-- Get_Interrupt_Mask
+-- Set_Interrupt_Mask
+-- IS_Member
+-- Environment_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Error_Reporting;
+-- used for Shutdown
+
+with System.Task_Primitives.Operations;
+-- used for Write_Lock
+-- Unlock
+-- Abort
+-- Wakeup_Task
+-- Sleep
+-- Initialize_Lock
+
+with System.Task_Primitives.Interrupt_Operations;
+-- used for Set_Interrupt_ID
+
+with System.Storage_Elements;
+-- used for To_Address
+-- To_Integer
+-- Integer_Address
+
+with System.Tasking;
+-- used for Task_ID
+-- Task_Entry_Index
+-- Null_Task
+-- Self
+-- Interrupt_Manager_ID
+
+with System.Tasking.Utilities;
+-- used for Make_Independent
+
+with System.Tasking.Rendezvous;
+-- used for Call_Simple
+pragma Elaborate_All (System.Tasking.Rendezvous);
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort
+-- Undefer_Abort
+
+with Unchecked_Conversion;
+
+package body System.Interrupts is
+
+ use Tasking;
+ use System.Error_Reporting;
+ use Ada.Exceptions;
+
+ package PRI renames System.Task_Primitives;
+ 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 Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_ID);
+
+ -----------------
+ -- Local Tasks --
+ -----------------
+
+ -- WARNING: System.Tasking.Utilities performs calls to this task
+ -- with low-level constructs. Do not change this spec without synchro-
+ -- nizing it.
+
+ task Interrupt_Manager is
+ entry Initialize (Mask : IMNG.Interrupt_Mask);
+
+ entry Attach_Handler
+ (New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in Boolean := False);
+
+ entry Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean);
+
+ entry Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean);
+
+ entry Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID);
+
+ entry Detach_Interrupt_Entries (T : Task_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);
+ 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 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 :
+ 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".
+
+ L : aliased PRI.RTS_Lock;
+ -- L protects contents in tables above corresponding to interrupts
+ -- for which Server_ID (T) = null.
+ --
+ -- If Server_ID (T) /= null then protection is via
+ -- per-task (TCB) lock of Server_ID (T).
+ --
+ -- For deadlock prevention, L should not be locked after
+ -- any other lock is held, hence we use PO_Level which is the highest
+ -- lock level for error checking.
+
+ Task_Lock : array (Interrupt_ID'Range) of Boolean := (others => False);
+ -- Boolean flags to give matching Locking and Unlocking. See the comments
+ -- in Lock_Interrupt.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Lock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID);
+ -- protect the tables using L or per-task lock. Set the Boolean
+ -- value Task_Lock if the lock is made using per-task lock.
+ -- This information is needed so that Unlock_Interrupt
+ -- performs unlocking on the same lock. The situation we are preventing
+ -- is, for example, when Attach_Handler is called for the first time
+ -- we lock L and create an Server_Task. For a matching unlocking, if we
+ -- rely on the fact that there is a Server_Task, we will unlock the
+ -- per-task lock.
+
+ procedure Unlock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID);
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- ??? spec needs comments
+
+ --------------------
+ -- 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 (ie. 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 : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "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 : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "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 (ie. 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 : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "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
+ 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 Dynamic_Interrupt_Protection) return Boolean is
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ 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_Exception (Program_Error'Identity, "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 : in 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;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ return Ignored (Interrupt);
+ end Is_Ignored;
+
+ -------------------
+ -- 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
+
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new 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;
+
+ --------------------
+ -- Lock_Interrupt --
+ --------------------
+
+ -- ?????
+
+ -- This package has been modified several times.
+ -- Do we still need this fancy locking scheme, now that more operations
+ -- are entries of the interrupt manager task?
+
+ -- ?????
+
+ -- More likely, we will need to convert one or more entry calls to
+ -- protected operations, because presently we are violating locking order
+ -- rules by calling a task entry from within the runtime system.
+
+ procedure Lock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ Initialization.Defer_Abort (Self_ID);
+
+ POP.Write_Lock (L'Access);
+
+ if Task_Lock (Interrupt) then
+
+ -- We need to use per-task lock.
+
+ POP.Unlock (L'Access);
+ POP.Write_Lock (Server_ID (Interrupt));
+
+ -- Rely on the fact that once Server_ID is set to a non-null
+ -- value it will never be set back to null.
+
+ elsif Server_ID (Interrupt) /= Null_Task then
+
+ -- We need to use per-task lock.
+
+ Task_Lock (Interrupt) := True;
+ POP.Unlock (L'Access);
+ POP.Write_Lock (Server_ID (Interrupt));
+ end if;
+ end Lock_Interrupt;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ if Is_Reserved (Interrupt) then
+ Raise_Exception (Program_Error'Identity, "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 rgistered.
+ -- 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_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "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_Exception (Program_Error'Identity, "Interrupt" &
+ Interrupt_ID'Image (Interrupt) & " is reserved");
+ end if;
+
+ Interrupt_Manager.Unignore_Interrupt (Interrupt);
+ end Unignore_Interrupt;
+
+ ----------------------
+ -- Unlock_Interrupt --
+ ----------------------
+
+ procedure Unlock_Interrupt
+ (Self_ID : Task_ID;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ if Task_Lock (Interrupt) then
+ POP.Unlock (Server_ID (Interrupt));
+ else
+ POP.Unlock (L'Access);
+ end if;
+
+ Initialization.Undefer_Abort (Self_ID);
+ end Unlock_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;
+ Self_ID : Task_ID := POP.Self;
+
+ ---------------------
+ -- 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.
+
+ -- Following two procedure are named Unprotected... in order to
+ -- indicate that Lock/Unlock_Interrupt operations are needed around.
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in Boolean := False);
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in 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 actuall 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
+ 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
+
+ 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));
+
+ 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 : in Interrupt_ID;
+ Static : in 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).
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "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.
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "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 : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in 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).
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "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
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "Trying to overwrite a static Interrupt Handler with a " &
+ "dynamic Handler");
+ end if;
+
+ -- The interrupt should no longer be ingnored 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;
+
+ -- Environmen 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 explicitely 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 senarios.
+
+ -- 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 nean time we have the Interrupt_Manager umnasked 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" simaltaneously 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
+
+ declare
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ select
+
+ accept Attach_Handler
+ (New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean;
+ Restoration : in Boolean := False)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static, Restoration);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Attach_Handler;
+
+ or accept Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : in Parameterless_Handler;
+ Interrupt : in Interrupt_ID;
+ Static : in Boolean)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Exchange_Handler;
+
+ or accept Detach_Handler
+ (Interrupt : in Interrupt_ID;
+ Static : in Boolean)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+ Unprotected_Detach_Handler (Interrupt, Static);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Detach_Handler;
+
+ or accept Bind_Interrupt_To_Entry
+ (T : Task_ID;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID)
+ do
+ Lock_Interrupt (Self_ID, Interrupt);
+
+ -- 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
+ Unlock_Interrupt (Self_ID, Interrupt);
+ Raise_Exception (Program_Error'Identity,
+ "A binding for this interrupt is already present");
+ end if;
+
+ -- The interrupt should no longer be ingnored 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
+
+ -- 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);
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ or accept Detach_Interrupt_Entries (T : Task_ID)
+ do
+ for I in Interrupt_ID'Range loop
+ if not Is_Reserved (I) then
+ Lock_Interrupt (Self_ID, I);
+
+ if User_Entry (I).T = T then
+
+ -- The interrupt should no longer be ingnored if
+ -- it was ever ignored.
+
+ Ignored (I) := False;
+ User_Entry (I) := Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
+ Unbind_Handler (I);
+ end if;
+
+ Unlock_Interrupt (Self_ID, I);
+ 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
+ Lock_Interrupt (Self_ID, Interrupt);
+
+ if Blocked (Interrupt) then
+ Unlock_Interrupt (Self_ID, Interrupt);
+ 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;
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Block_Interrupt;
+
+ or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
+ Lock_Interrupt (Self_ID, Interrupt);
+
+ if not Blocked (Interrupt) then
+ Unlock_Interrupt (Self_ID, Interrupt);
+ 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;
+
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Unblock_Interrupt;
+
+ or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
+ Lock_Interrupt (Self_ID, Interrupt);
+
+ if Ignored (Interrupt) then
+ Unlock_Interrupt (Self_ID, Interrupt);
+ 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));
+ Unlock_Interrupt (Self_ID, Interrupt);
+ end Ignore_Interrupt;
+
+ or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
+ Lock_Interrupt (Self_ID, Interrupt);
+ 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));
+ Unlock_Interrupt (Self_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
+ (Shutdown ("Interrupt_Manager---exception not expected"));
+ null;
+ end;
+
+ end loop;
+
+ pragma Assert (Shutdown ("Interrupt_Manager---should not get here"));
+
+ end Interrupt_Manager;
+
+ -----------------
+ -- Server_Task --
+ -----------------
+
+ task body Server_Task is
+ Intwait_Mask : aliased IMNG.Interrupt_Mask;
+ Ret_Interrupt : Interrupt_ID;
+ Self_ID : 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 explicitely 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 execure 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);
+ 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 exceute the attached Procedure or Entry.
+
+ POP.Unlock (Self_ID);
+
+ Ret_Interrupt :=
+ Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
+
+ 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);
+ POP.Write_Lock (Self_ID);
+
+ else
+ pragma Assert (Ret_Interrupt = Interrupt);
+
+ POP.Write_Lock (Self_ID);
+
+ -- 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);
+
+ Tmp_Handler.all;
+ 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);
+
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ POP.Write_Lock (Self_ID);
+ else
+ -- This is a situation that this task wake up
+ -- receiving an Interrupt and before it get the lock
+ -- the Interrupt is blocked. We do not
+ -- want to lose the interrupt in this case so that
+ -- regenerate the Interrupt to process level;
+
+ IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt));
+ end if;
+ end if;
+
+ end if;
+
+ POP.Unlock (Self_ID);
+ 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;
+
+ pragma Assert (Shutdown ("Server_Task---should not get here"));
+ 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);
+
+ -- Initialize the lock L.
+
+ Initialization.Defer_Abort (Self);
+ POP.Initialize_Lock (L'Access, POP.PO_Level);
+ Initialization.Undefer_Abort (Self);
+
+ -- 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.ads b/gcc/ada/s-interr.ads
new file mode 100644
index 00000000000..e6cc8836395
--- /dev/null
+++ b/gcc/ada/s-interr.ads
@@ -0,0 +1,281 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 in order to allow
+-- System.Interrupt_Management to be used without requiring the whole
+-- tasking implementation to be linked and elaborated.
+
+with System.Tasking;
+-- used for Task_ID
+
+with System.Tasking.Protected_Objects.Entries;
+-- used for Protection_Entries
+
+with System.OS_Interface;
+-- used for Max_Interrupt
+
+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;
+
+ 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
+ -- Attempt to bind an Entry to an Interrupt to which a Handler is
+ -- already attached will raise a Program_Error.
+
+ procedure Bind_Interrupt_To_Entry
+ (T : System.Tasking.Task_ID;
+ E : System.Tasking.Task_Entry_Index;
+ Int_Ref : System.Address);
+
+ 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 sigacion 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 acheive 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 objet 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 Interrup_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 : in New_Handler_Array);
+ -- Store the old handlers in Object.Previous_Handlers and install
+ -- the new static handlers.
+
+end System.Interrupts;
diff --git a/gcc/ada/s-intman.ads b/gcc/ada/s-intman.ads
new file mode 100644
index 00000000000..0f89bd7f508
--- /dev/null
+++ b/gcc/ada/s-intman.ads
@@ -0,0 +1,128 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1991-1998 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+-- This is designed to work for both tasking and non-tasking systems,
+-- without pulling in any of the tasking support.
+
+-- PLEASE DO NOT remove the Elaborate_Body pragma from this package.
+-- Elaboration of this package should happen early, as most other
+-- initializations depend on it.
+-- Forcing immediate elaboration of the body also helps to enforce
+-- the design assumption that this is a second-level
+-- package, just one level above System.OS_Interface, with no
+-- cross-dependences.
+
+-- 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;
+-- used for Signal
+-- sigset_t
+
+package System.Interrupt_Management is
+
+ pragma Elaborate_Body;
+
+ 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;
+ -- and the initialization code will be portable.
+
+ Abort_Task_Interrupt : Interrupt_ID;
+ -- The interrupt that is used to implement task abortion,
+ -- 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 abortion,
+ -- or used to implement time delays.
+
+ 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_Interrupts;
+ -- On systems where there is no signal inheritance between tasks (e.g
+ -- VxWorks, LinuxThreads), this procedure is used to initialize interrupts
+ -- handling in each task. Otherwise this function should only be called by
+ -- initialize in this package body.
+
+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-io.adb b/gcc/ada/s-io.adb
new file mode 100644
index 00000000000..b768d9ac2ac
--- /dev/null
+++ b/gcc/ada/s-io.adb
@@ -0,0 +1,88 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.IO is
+
+ --------------
+ -- 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");
+
+ begin
+ Put_Int (X);
+ end Put;
+
+ procedure Put (C : Character) is
+
+ procedure Put_Char (C : Character);
+ pragma Import (C, Put_Char, "put_char");
+
+ begin
+ Put_Char (C);
+ 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;
+
+end System.IO;
diff --git a/gcc/ada/s-io.ads b/gcc/ada/s-io.ads
new file mode 100644
index 00000000000..a722736eed8
--- /dev/null
+++ b/gcc/ada/s-io.ads
@@ -0,0 +1,53 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (IO);
+
+ procedure Put (X : Integer);
+
+ procedure Put (C : Character);
+
+ procedure Put (S : String);
+ procedure Put_Line (S : String);
+
+ procedure New_Line (Spacing : Positive := 1);
+
+end System.IO;
diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads
new file mode 100644
index 00000000000..cecdb082dc8
--- /dev/null
+++ b/gcc/ada/s-maccod.ads
@@ -0,0 +1,134 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . M A C H I N E _ C O D E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides machine code support, both for instrinsic machine
+-- operations, and also for machine code statements. See GNAT documentation
+-- for full details.
+
+package System.Machine_Code is
+pragma Pure (Machine_Code);
+
+ 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 consistenty. 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 00000000000..ff9cb8b9e7d
--- /dev/null
+++ b/gcc/ada/s-mantis.adb
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . M A N T I S S A --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..ae5b5a679c8
--- /dev/null
+++ b/gcc/ada/s-mantis.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . M A N T I S S A --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Mantissa);
+
+ function Mantissa_Value (First, Last : Integer) return Natural;
+ -- Compute Mantissa value from the given arguments, which are the First
+ -- and Last value of the fixed-point type, in Integer'Integer_Value form.
+
+end System.Mantissa;
diff --git a/gcc/ada/s-mastop.adb b/gcc/ada/s-mastop.adb
new file mode 100644
index 00000000000..16e7de2ff70
--- /dev/null
+++ b/gcc/ada/s-mastop.adb
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- SYSTEM.MACHINE_STATE_OPERATIONS --
+-- --
+-- B o d y --
+-- (Dummy version) --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This dummy version of System.Machine_State_Operations is used
+-- on targets for which zero cost exception handling is not implemented.
+
+package body System.Machine_State_Operations is
+
+ use System.Exceptions;
+
+ ----------------------------
+ -- Allocate_Machine_State --
+ ----------------------------
+
+ function Allocate_Machine_State return Machine_State is
+ begin
+ return Machine_State (Null_Address);
+ end Allocate_Machine_State;
+
+ -------------------
+ -- Enter_Handler --
+ -------------------
+
+ procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
+ begin
+ null;
+ end Enter_Handler;
+
+ ----------------
+ -- 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;
+ Info : Subprogram_Info_Type) is
+ begin
+ null;
+ end Pop_Frame;
+
+ -----------------------
+ -- Set_Machine_State --
+ -----------------------
+
+ procedure Set_Machine_State (M : Machine_State) is
+ begin
+ null;
+ end Set_Machine_State;
+
+ ------------------------------
+ -- Set_Signal_Machine_State --
+ ------------------------------
+
+ procedure Set_Signal_Machine_State
+ (M : Machine_State;
+ Context : System.Address) is
+ begin
+ null;
+ end Set_Signal_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 00000000000..ef0282bf524
--- /dev/null
+++ b/gcc/ada/s-mastop.ads
@@ -0,0 +1,165 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- SYSTEM.MACHINE_STATE_OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+with System.Exceptions;
+
+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;
+ Info : System.Exceptions.Subprogram_Info_Type);
+ -- 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.
+ --
+ -- The Info parameter represents information generated by the backend
+ -- (see description of Subprogram_Info node in sinfo.ads). This
+ -- information is stored as static data during compilation. The
+ -- caller then passes this information to Pop_Frame, which will
+ -- use it to determine what must be changed in the machine state
+ -- (e.g. which save-over-call registers must be restored, and from
+ -- where on the stack frame they must be restored).
+ --
+ -- A value of No_Info for Info means either that the backend provided
+ -- no information for current frame, or that the current frame is an
+ -- other language frame for which no information exists, or that this
+ -- is an outer level subprogram. In any case, Pop_Frame sets the code
+ -- location to Null_Address when it pops past such a frame, and this
+ -- is taken as an indication that the exception is unhandled.
+
+ -- Note: at the current time, Info, if present is always a copy of
+ -- the entry point of the procedure, as found by searching the
+ -- subprogram table. For the case where a procedure is indeed in
+ -- the table (either it is an Ada procedure, or a foreign procedure
+ -- which is registered using pragma Propagate_Exceptions), then the
+ -- entry point information will indeed be correct. It may well be
+ -- possible for Pop_Frame to avoid using the Info parameter (for
+ -- example if it consults auxiliary Dwarf tables to do its job).
+ -- This is desirable if it can be done, because it means that it
+ -- will work fine to propagate exceptions through unregistered
+ -- foreign procedures. What will happen is that the search in the
+ -- Ada subprogram table will find a junk entry. Even if this junk
+ -- entry has an exception table, none of them will apply to the
+ -- current location, so they will be ignored, and then Pop_Frame
+ -- will be called to pop the frame. The Info parameter for this
+ -- call will be junk, but if it is not used that does not matter.
+ -- Note that the address recorded in the traceback table is of
+ -- the exception location, so the traceback will be correct even
+ -- in this case.
+
+ procedure Enter_Handler
+ (M : Machine_State;
+ Handler : System.Exceptions.Handler_Loc);
+ -- When Propagate_Handler locates an applicable exception handler, it
+ -- calls Enter_Handler, passing it two parameters. The first is the
+ -- machine state that corresponds to what is required for entry to
+ -- the handler, as computed by repeated Pop_Frame calls to reach the
+ -- handler to be entered. The second is the code location for the
+ -- handler itself which is the address of the label at the start of
+ -- the handler code.
+ --
+ -- Note: The machine state M is likely stored on the part of the
+ -- stack that will be popped by the call, so care must be taken
+ -- not to pop the stack until the Machine_State is entirely read.
+ -- The value passed as Handler was obtained from elaboration of
+ -- an N_Handler_Loc node by the backend.
+
+ 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.
+ -- Do not add pragma Inline, see 9116-002.
+ -- ??? This function will go away when 'Code_Address is fixed on VMS.
+
+ 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.
+
+ procedure Set_Signal_Machine_State
+ (M : Machine_State;
+ Context : System.Address);
+ -- This routine sets M from the machine state that corresponds to the
+ -- point in the code where a signal was raised. The parameter Context
+ -- is a pointer to a structure created by the operating system when a
+ -- signal is raised, and made available to the signal handler. The
+ -- format of this context block, and the manner in which it is made
+ -- available to the handler, are implementation dependent.
+
+end System.Machine_State_Operations;
diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb
new file mode 100644
index 00000000000..4f11aeca738
--- /dev/null
+++ b/gcc/ada/s-memory.adb
@@ -0,0 +1,142 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M E M O R Y --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 abortion because on most systems,
+-- an asynchronous signal (as used for implementing asynchronous abortion
+-- 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.
+
+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");
+
+ -----------
+ -- 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;
+
+ Abort_Defer.all;
+ Result := c_malloc (Actual_Size);
+ Abort_Undefer.all;
+
+ 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
+ Abort_Defer.all;
+ c_free (Ptr);
+ Abort_Undefer.all;
+ end Free;
+
+ -------------
+ -- Realloc --
+ -------------
+
+ function Realloc
+ (Ptr : System.Address;
+ 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;
+
+ Abort_Defer.all;
+ Result := c_realloc (Ptr, Actual_Size);
+ Abort_Undefer.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Realloc;
+
+end System.Memory;
diff --git a/gcc/ada/s-memory.ads b/gcc/ada/s-memory.ads
new file mode 100644
index 00000000000..6dafe93b877
--- /dev/null
+++ b/gcc/ada/s-memory.ads
@@ -0,0 +1,72 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M E M O R Y --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+
+package System.Memory is
+ pragma Elaborate_Body;
+
+ type size_t is mod 2 ** Standard'Address_Size;
+
+ function Alloc (Size : size_t) return System.Address;
+ -- malloc for use by GNAT, with error checking and task lockout,
+ -- as well as allocation tracking.
+
+ procedure Free (Ptr : System.Address);
+ -- free for use by GNAT, with task lockout and allocation tracking.
+
+ function Realloc
+ (Ptr : System.Address;
+ Size : size_t)
+ return System.Address;
+ -- realloc for use by GNAT, with error checking and task lockout.
+
+private
+
+ 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-osprim.ads b/gcc/ada/s-osprim.ads
new file mode 100644
index 00000000000..2ee6ae077b3
--- /dev/null
+++ b/gcc/ada/s-osprim.ads
@@ -0,0 +1,86 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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-tasoli.ads)
+
+-- NEVER add any dependency to tasking packages here
+
+package System.OS_Primitives is
+
+ Max_Sensible_Delay : constant Duration := 183 * 24 * 60 * 60.0;
+ -- 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
+ -- 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).
+
+ function Clock return Duration;
+ pragma Inline (Clock);
+ -- Returns "absolute" time, represented as an offset
+ -- relative to "the Epoch", which is Jan 1, 1970 on unixes.
+ -- 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 Epoch", which is Jan 1, 1970.
+ -- 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 00000000000..e93835b5ded
--- /dev/null
+++ b/gcc/ada/s-pack03.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..a9c3c27e1ef
--- /dev/null
+++ b/gcc/ada/s-pack03.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handing of packed arrays with Component_Size = 3
+
+package System.Pack_03 is
+pragma Preelaborate (Pack_03);
+
+ 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 00000000000..8ebb5ba829e
--- /dev/null
+++ b/gcc/ada/s-pack05.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..f025a26ae04
--- /dev/null
+++ b/gcc/ada/s-pack05.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 5 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-0507, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 5
+
+package System.Pack_05 is
+pragma Preelaborate (Pack_05);
+
+ 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 00000000000..8d48bb8f423
--- /dev/null
+++ b/gcc/ada/s-pack06.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 6 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..d35607fa184
--- /dev/null
+++ b/gcc/ada/s-pack06.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 6 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 6
+
+package System.Pack_06 is
+pragma Preelaborate (Pack_06);
+
+ 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 00000000000..510ddecd043
--- /dev/null
+++ b/gcc/ada/s-pack07.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 7 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..e0ae2b9cf2a
--- /dev/null
+++ b/gcc/ada/s-pack07.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 7 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-0707, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 7
+
+package System.Pack_07 is
+pragma Preelaborate (Pack_07);
+
+ 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 00000000000..26931bf2982
--- /dev/null
+++ b/gcc/ada/s-pack09.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 9 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..017dd582636
--- /dev/null
+++ b/gcc/ada/s-pack09.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 0 9 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-0907, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 9
+
+package System.Pack_09 is
+pragma Preelaborate (Pack_09);
+
+ 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 00000000000..42442e18976
--- /dev/null
+++ b/gcc/ada/s-pack10.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 0 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..97c98b46cae
--- /dev/null
+++ b/gcc/ada/s-pack10.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 0 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 10
+
+package System.Pack_10 is
+pragma Preelaborate (Pack_10);
+
+ 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 00000000000..ca4f51ccfc5
--- /dev/null
+++ b/gcc/ada/s-pack11.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 1 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..8eb527b1c24
--- /dev/null
+++ b/gcc/ada/s-pack11.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 1 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-1107, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 11
+
+package System.Pack_11 is
+pragma Preelaborate (Pack_11);
+
+ 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 00000000000..958c88140ba
--- /dev/null
+++ b/gcc/ada/s-pack12.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 2 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..c31b9b6237b
--- /dev/null
+++ b/gcc/ada/s-pack12.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 2 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 12
+
+package System.Pack_12 is
+pragma Preelaborate (Pack_12);
+
+ 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 00000000000..9da7f1cdf0c
--- /dev/null
+++ b/gcc/ada/s-pack13.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..b0b89760a00
--- /dev/null
+++ b/gcc/ada/s-pack13.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 13
+
+package System.Pack_13 is
+pragma Preelaborate (Pack_13);
+
+ 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 00000000000..cc4c5cea3ac
--- /dev/null
+++ b/gcc/ada/s-pack14.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..cceb1ba27dc
--- /dev/null
+++ b/gcc/ada/s-pack14.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 4 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handing of packed arrays with Component_Size = 14
+
+package System.Pack_14 is
+pragma Preelaborate (Pack_14);
+
+ 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 00000000000..64f8ba584fa
--- /dev/null
+++ b/gcc/ada/s-pack15.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..3861797dd53
--- /dev/null
+++ b/gcc/ada/s-pack15.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 5 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-1507, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 15
+
+package System.Pack_15 is
+pragma Preelaborate (Pack_15);
+
+ 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 00000000000..0fa9a1da0b6
--- /dev/null
+++ b/gcc/ada/s-pack17.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 7 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..697d2f39afb
--- /dev/null
+++ b/gcc/ada/s-pack17.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 7 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-1707, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 17
+
+package System.Pack_17 is
+pragma Preelaborate (Pack_17);
+
+ 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 00000000000..6741f1b77cc
--- /dev/null
+++ b/gcc/ada/s-pack18.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 8 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..7f3b78f5307
--- /dev/null
+++ b/gcc/ada/s-pack18.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 8 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 18
+
+package System.Pack_18 is
+pragma Preelaborate (Pack_18);
+
+ 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 00000000000..2aea9eae4cd
--- /dev/null
+++ b/gcc/ada/s-pack19.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 9 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..c5103605247
--- /dev/null
+++ b/gcc/ada/s-pack19.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 1 9 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-1907, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 19
+
+package System.Pack_19 is
+pragma Preelaborate (Pack_19);
+
+ 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 00000000000..9a09533a927
--- /dev/null
+++ b/gcc/ada/s-pack20.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 0 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..626f2ccf1aa
--- /dev/null
+++ b/gcc/ada/s-pack20.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 0 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 20
+
+package System.Pack_20 is
+pragma Preelaborate (Pack_20);
+
+ 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 00000000000..d29d6624541
--- /dev/null
+++ b/gcc/ada/s-pack21.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 1 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..46d1d530109
--- /dev/null
+++ b/gcc/ada/s-pack21.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 1 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-2107, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 21
+
+package System.Pack_21 is
+pragma Preelaborate (Pack_21);
+
+ 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 00000000000..e405a74a5cc
--- /dev/null
+++ b/gcc/ada/s-pack22.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 2 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..42872b4c948
--- /dev/null
+++ b/gcc/ada/s-pack22.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 2 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 22
+
+package System.Pack_22 is
+pragma Preelaborate (Pack_22);
+
+ 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 00000000000..e15445e3a64
--- /dev/null
+++ b/gcc/ada/s-pack23.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..5e3c6ceed8e
--- /dev/null
+++ b/gcc/ada/s-pack23.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-2307, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 23
+
+package System.Pack_23 is
+pragma Preelaborate (Pack_23);
+
+ 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 00000000000..26e37f5cf57
--- /dev/null
+++ b/gcc/ada/s-pack24.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..e315f8c1f61
--- /dev/null
+++ b/gcc/ada/s-pack24.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 4 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 24
+
+package System.Pack_24 is
+pragma Preelaborate (Pack_24);
+
+ 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 00000000000..e9399ad69c6
--- /dev/null
+++ b/gcc/ada/s-pack25.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..2abc74716a6
--- /dev/null
+++ b/gcc/ada/s-pack25.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 5 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-2507, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 25
+
+package System.Pack_25 is
+pragma Preelaborate (Pack_25);
+
+ 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 00000000000..c3af1491c40
--- /dev/null
+++ b/gcc/ada/s-pack26.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 6 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..fc9a05aa165
--- /dev/null
+++ b/gcc/ada/s-pack26.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 6 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 26
+
+package System.Pack_26 is
+pragma Preelaborate (Pack_26);
+
+ 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 00000000000..a637f9212d8
--- /dev/null
+++ b/gcc/ada/s-pack27.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 7 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..28d1b57740a
--- /dev/null
+++ b/gcc/ada/s-pack27.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 7 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-2707, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 27
+
+package System.Pack_27 is
+pragma Preelaborate (Pack_27);
+
+ 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 00000000000..84afb9afacd
--- /dev/null
+++ b/gcc/ada/s-pack28.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 8 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..125321e28df
--- /dev/null
+++ b/gcc/ada/s-pack28.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 8 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 28
+
+package System.Pack_28 is
+pragma Preelaborate (Pack_28);
+
+ 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 00000000000..5b5792b52c8
--- /dev/null
+++ b/gcc/ada/s-pack29.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 9 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..dcd20fae239
--- /dev/null
+++ b/gcc/ada/s-pack29.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 2 9 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-2907, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 29
+
+package System.Pack_29 is
+pragma Preelaborate (Pack_29);
+
+ 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 00000000000..b493250e05a
--- /dev/null
+++ b/gcc/ada/s-pack30.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 0 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..77714a54194
--- /dev/null
+++ b/gcc/ada/s-pack30.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 0 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 30
+
+package System.Pack_30 is
+pragma Preelaborate (Pack_30);
+
+ 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 00000000000..cb7ec025d27
--- /dev/null
+++ b/gcc/ada/s-pack31.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 1 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..ab084ae392d
--- /dev/null
+++ b/gcc/ada/s-pack31.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 1 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-3107, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 31
+
+package System.Pack_31 is
+pragma Preelaborate (Pack_31);
+
+ 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 00000000000..d5f7972c3de
--- /dev/null
+++ b/gcc/ada/s-pack33.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..1c3bb2576f8
--- /dev/null
+++ b/gcc/ada/s-pack33.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-3307, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 33
+
+package System.Pack_33 is
+pragma Preelaborate (Pack_33);
+
+ 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 00000000000..291b6958b27
--- /dev/null
+++ b/gcc/ada/s-pack34.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..17f35207927
--- /dev/null
+++ b/gcc/ada/s-pack34.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 4 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 34
+
+package System.Pack_34 is
+pragma Preelaborate (Pack_34);
+
+ 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 00000000000..ef5a50b1e2e
--- /dev/null
+++ b/gcc/ada/s-pack35.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..c1658f8ec97
--- /dev/null
+++ b/gcc/ada/s-pack35.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 5 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-3507, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 35
+
+package System.Pack_35 is
+pragma Preelaborate (Pack_35);
+
+ 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 00000000000..f9a1d6bdda0
--- /dev/null
+++ b/gcc/ada/s-pack36.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 6 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..dc12fd3404a
--- /dev/null
+++ b/gcc/ada/s-pack36.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 6 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 36
+
+package System.Pack_36 is
+pragma Preelaborate (Pack_36);
+
+ 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 00000000000..42c4494e0e2
--- /dev/null
+++ b/gcc/ada/s-pack37.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 7 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..702d0f03798
--- /dev/null
+++ b/gcc/ada/s-pack37.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 7 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-3707, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 37
+
+package System.Pack_37 is
+pragma Preelaborate (Pack_37);
+
+ 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 00000000000..71bc7d247bb
--- /dev/null
+++ b/gcc/ada/s-pack38.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 8 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..4b68c9abd85
--- /dev/null
+++ b/gcc/ada/s-pack38.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 8 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 38
+
+package System.Pack_38 is
+pragma Preelaborate (Pack_38);
+
+ 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 00000000000..5f813e3918a
--- /dev/null
+++ b/gcc/ada/s-pack39.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 9 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..755a7a27048
--- /dev/null
+++ b/gcc/ada/s-pack39.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 3 9 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-3907, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 39
+
+package System.Pack_39 is
+pragma Preelaborate (Pack_39);
+
+ 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 00000000000..1c9e598686f
--- /dev/null
+++ b/gcc/ada/s-pack40.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 0 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..0258e504a15
--- /dev/null
+++ b/gcc/ada/s-pack40.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 0 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 40
+
+package System.Pack_40 is
+pragma Preelaborate (Pack_40);
+
+ 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 00000000000..0997598c32d
--- /dev/null
+++ b/gcc/ada/s-pack41.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 1 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..0de507ab415
--- /dev/null
+++ b/gcc/ada/s-pack41.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 1 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-4107, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 41
+
+package System.Pack_41 is
+pragma Preelaborate (Pack_41);
+
+ 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 00000000000..2a2d393d877
--- /dev/null
+++ b/gcc/ada/s-pack42.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 2 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..971e147f475
--- /dev/null
+++ b/gcc/ada/s-pack42.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 2 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 42
+
+package System.Pack_42 is
+pragma Preelaborate (Pack_42);
+
+ 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 00000000000..727feeb7cca
--- /dev/null
+++ b/gcc/ada/s-pack43.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..bcc30f9230f
--- /dev/null
+++ b/gcc/ada/s-pack43.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-4307, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 43
+
+package System.Pack_43 is
+pragma Preelaborate (Pack_43);
+
+ 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 00000000000..09bcba08109
--- /dev/null
+++ b/gcc/ada/s-pack44.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..84ef9c7cc1c
--- /dev/null
+++ b/gcc/ada/s-pack44.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 4 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 44
+
+package System.Pack_44 is
+pragma Preelaborate (Pack_44);
+
+ 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 00000000000..871940ec39d
--- /dev/null
+++ b/gcc/ada/s-pack45.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..b2d1e296b8f
--- /dev/null
+++ b/gcc/ada/s-pack45.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 5 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-4507, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 45
+
+package System.Pack_45 is
+pragma Preelaborate (Pack_45);
+
+ 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 00000000000..c0d24cc505d
--- /dev/null
+++ b/gcc/ada/s-pack46.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 6 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..2d688dd76fa
--- /dev/null
+++ b/gcc/ada/s-pack46.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 6 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 46
+
+package System.Pack_46 is
+pragma Preelaborate (Pack_46);
+
+ 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 00000000000..4d1b0fe0b2a
--- /dev/null
+++ b/gcc/ada/s-pack47.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 7 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..b09d7ee9473
--- /dev/null
+++ b/gcc/ada/s-pack47.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 7 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-4707, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 47
+
+package System.Pack_47 is
+pragma Preelaborate (Pack_47);
+
+ 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 00000000000..90d0d251f63
--- /dev/null
+++ b/gcc/ada/s-pack48.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 8 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..e4aa93502c1
--- /dev/null
+++ b/gcc/ada/s-pack48.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 8 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 48
+
+package System.Pack_48 is
+pragma Preelaborate (Pack_48);
+
+ 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 00000000000..442131f18c1
--- /dev/null
+++ b/gcc/ada/s-pack49.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 9 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..fd25c5879fc
--- /dev/null
+++ b/gcc/ada/s-pack49.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 4 9 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-4907, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 49
+
+package System.Pack_49 is
+pragma Preelaborate (Pack_49);
+
+ 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 00000000000..e0bb450dda9
--- /dev/null
+++ b/gcc/ada/s-pack50.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 0 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..48f2eb1b29b
--- /dev/null
+++ b/gcc/ada/s-pack50.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 0 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 50
+
+package System.Pack_50 is
+pragma Preelaborate (Pack_50);
+
+ 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 00000000000..330f1627f58
--- /dev/null
+++ b/gcc/ada/s-pack51.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 1 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..c59e5ea3d1e
--- /dev/null
+++ b/gcc/ada/s-pack51.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 1 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-5107, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 51
+
+package System.Pack_51 is
+pragma Preelaborate (Pack_51);
+
+ 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 00000000000..91ee440f411
--- /dev/null
+++ b/gcc/ada/s-pack52.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 2 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..10264dfaab9
--- /dev/null
+++ b/gcc/ada/s-pack52.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 2 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 52
+
+package System.Pack_52 is
+pragma Preelaborate (Pack_52);
+
+ 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 00000000000..ff56f075839
--- /dev/null
+++ b/gcc/ada/s-pack53.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..e9e2b8a8536
--- /dev/null
+++ b/gcc/ada/s-pack53.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-5307, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 53
+
+package System.Pack_53 is
+pragma Preelaborate (Pack_53);
+
+ 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 00000000000..d389e399954
--- /dev/null
+++ b/gcc/ada/s-pack54.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..7f1d4ebf598
--- /dev/null
+++ b/gcc/ada/s-pack54.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 4 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 54
+
+package System.Pack_54 is
+pragma Preelaborate (Pack_54);
+
+ 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 00000000000..e353ed4338f
--- /dev/null
+++ b/gcc/ada/s-pack55.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..68b0aaad3c5
--- /dev/null
+++ b/gcc/ada/s-pack55.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 5 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-5507, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 55
+
+package System.Pack_55 is
+pragma Preelaborate (Pack_55);
+
+ 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 00000000000..4300bd6230c
--- /dev/null
+++ b/gcc/ada/s-pack56.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 6 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..94ae0a51b1b
--- /dev/null
+++ b/gcc/ada/s-pack56.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 6 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 56
+
+package System.Pack_56 is
+pragma Preelaborate (Pack_56);
+
+ 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 00000000000..077124e9a38
--- /dev/null
+++ b/gcc/ada/s-pack57.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 7 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..ab5f137c77e
--- /dev/null
+++ b/gcc/ada/s-pack57.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 7 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-5707, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 57
+
+package System.Pack_57 is
+pragma Preelaborate (Pack_57);
+
+ 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 00000000000..69011dc7325
--- /dev/null
+++ b/gcc/ada/s-pack58.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 8 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..debfb18faaa
--- /dev/null
+++ b/gcc/ada/s-pack58.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 8 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 58
+
+package System.Pack_58 is
+pragma Preelaborate (Pack_58);
+
+ 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 00000000000..fdfd208c635
--- /dev/null
+++ b/gcc/ada/s-pack59.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 9 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..2cfa7539282
--- /dev/null
+++ b/gcc/ada/s-pack59.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 5 9 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-5907, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 59
+
+package System.Pack_59 is
+pragma Preelaborate (Pack_59);
+
+ 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 00000000000..49771ff4f44
--- /dev/null
+++ b/gcc/ada/s-pack60.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 0 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..e795f355956
--- /dev/null
+++ b/gcc/ada/s-pack60.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 0 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 60
+
+package System.Pack_60 is
+pragma Preelaborate (Pack_60);
+
+ 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 00000000000..fb90abd68b5
--- /dev/null
+++ b/gcc/ada/s-pack61.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 1 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..f9138fd942c
--- /dev/null
+++ b/gcc/ada/s-pack61.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 1 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-6107, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 61
+
+package System.Pack_61 is
+pragma Preelaborate (Pack_61);
+
+ 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 00000000000..31e3dafae77
--- /dev/null
+++ b/gcc/ada/s-pack62.adb
@@ -0,0 +1,171 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 2 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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
+ 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 00000000000..c4b85edbc62
--- /dev/null
+++ b/gcc/ada/s-pack62.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 2 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 62
+
+package System.Pack_62 is
+pragma Preelaborate (Pack_62);
+
+ 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 00000000000..80043d61a08
--- /dev/null
+++ b/gcc/ada/s-pack63.adb
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 3 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Unsigned_Types;
+with 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
+ 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 00000000000..2faa0d1ce52
--- /dev/null
+++ b/gcc/ada/s-pack63.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . P A C K _ 6 3 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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-6307, 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). --
+-- --
+------------------------------------------------------------------------------
+
+-- Handling of packed arrays with Component_Size = 63
+
+package System.Pack_63 is
+pragma Preelaborate (Pack_63);
+
+ 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.adb b/gcc/ada/s-parame.adb
new file mode 100644
index 00000000000..a5583cc3d6c
--- /dev/null
+++ b/gcc/ada/s-parame.adb
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1995-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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
+ begin
+ return 20 * 1024;
+ 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.ads b/gcc/ada/s-parame.ads
new file mode 100644
index 00000000000..92028c17398
--- /dev/null
+++ b/gcc/ada/s-parame.ads
@@ -0,0 +1,136 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.41 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default version used for all systems for which no special
+-- target-specific version of this package 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.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- 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
+
+ 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 ommitted only for outer level onjects 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)
+
+end System.Parameters;
diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb
new file mode 100644
index 00000000000..4d8e80d2706
--- /dev/null
+++ b/gcc/ada/s-parint.adb
@@ -0,0 +1,303 @@
+------------------------------------------------------------------------------
+-- --
+-- 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) --
+-- --
+-- $Revision: 1.21 $
+-- --
+-- Copyright (C) 1995-2000 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- 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 System.Partition_Interface is
+
+ 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;
+ 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 : in Unit_Name;
+ Version : in String;
+ RCI : in 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_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;
+
+ ------------
+ -- Launch --
+ ------------
+
+ procedure Launch
+ (Rsh_Command : in String;
+ Name_Is_Host : in Boolean;
+ General_Name : in String;
+ Command_Line : in String)
+ is
+ begin
+ null;
+ end Launch;
+
+ -----------
+ -- 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_For_E_4_18 --
+ ------------------------------------
+
+ procedure Raise_Program_Error_For_E_4_18 is
+ begin
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity,
+ "Illegal usage of remote access to class-wide type. See RM E.4(18)");
+ end Raise_Program_Error_For_E_4_18;
+
+ -------------------------------------
+ -- Raise_Program_Error_Unknown_Tag --
+ -------------------------------------
+
+ procedure Raise_Program_Error_Unknown_Tag
+ (E : in Ada.Exceptions.Exception_Occurrence)
+ is
+ begin
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, Ada.Exceptions.Exception_Message (E));
+ end Raise_Program_Error_Unknown_Tag;
+
+ --------------
+ -- RCI_Info --
+ --------------
+
+ package body RCI_Info 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_Info;
+
+ ------------------------------
+ -- Register_Passive_Package --
+ ------------------------------
+
+ procedure Register_Passive_Package
+ (Name : in Unit_Name;
+ Version : in String := "")
+ is
+ begin
+ Register_Receiving_Stub (Passive_Prefix & Name, null, Version);
+ end Register_Passive_Package;
+
+ -----------------------------
+ -- Register_Receiving_Stub --
+ -----------------------------
+
+ procedure Register_Receiving_Stub
+ (Name : in Unit_Name;
+ Receiver : in RPC.RPC_Receiver;
+ Version : in String := "")
+ is
+ begin
+ if Pkg_Tail = null then
+ Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null);
+ Pkg_Tail := Pkg_Head;
+
+ else
+ Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null);
+ Pkg_Tail := Pkg_Tail.Next;
+ end if;
+ end Register_Receiving_Stub;
+
+ ---------
+ -- Run --
+ ---------
+
+ procedure Run
+ (Main : in Main_Subprogram_Type := null)
+ is
+ begin
+ if Main /= null then
+ Main.all;
+ end if;
+ end Run;
+
+end System.Partition_Interface;
diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads
new file mode 100644
index 00000000000..f784583dbf0
--- /dev/null
+++ b/gcc/ada/s-parint.ads
@@ -0,0 +1,145 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.21 $
+-- --
+-- Copyright (C) 1995-2000 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- 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). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+with Interfaces;
+with System.RPC;
+
+package System.Partition_Interface is
+
+ pragma Elaborate_Body;
+
+ type Subprogram_Id is new Natural;
+ -- This type is used exclusively by stubs
+
+ 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.
+
+ procedure Check
+ (Name : in Unit_Name;
+ Version : in String;
+ RCI : in Boolean := True);
+ -- Use by the main subprogram to check that a remote receiver
+ -- unit has has the same version than the caller's one.
+
+ function Get_Active_Partition_ID
+ (Name : Unit_Name)
+ return RPC.Partition_ID;
+ -- Similar in some respects to RCI_Info.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_Info.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 Launch
+ (Rsh_Command : in String;
+ Name_Is_Host : in Boolean;
+ General_Name : in String;
+ Command_Line : in String);
+ -- General_Name represents the name of the machine or the name of the
+ -- partition (depending on the value of Name_Is_Host). Command_Line
+ -- holds the extra options that will be given on the command line.
+ -- Rsh_Command is typically "rsh", that will be used to launch the
+ -- other partition.
+
+ procedure Raise_Program_Error_For_E_4_18;
+ pragma No_Return (Raise_Program_Error_For_E_4_18);
+ -- Raise Program_Error with an error message explaining why it has been
+ -- raised. The rule in E.4 (18) is tricky and misleading for most users
+ -- of the distributed systems annex.
+
+ procedure Raise_Program_Error_Unknown_Tag
+ (E : in Ada.Exceptions.Exception_Occurrence);
+ pragma No_Return (Raise_Program_Error_Unknown_Tag);
+ -- Raise Program_Error with the same message as E one
+
+ procedure Register_Receiving_Stub
+ (Name : in Unit_Name;
+ Receiver : in RPC.RPC_Receiver;
+ Version : in String := "");
+ -- Register the fact that the Name receiving stub is now elaborated.
+ -- Register the access value to the package RPC_Receiver procedure.
+
+ procedure Register_Passive_Package
+ (Name : in Unit_Name;
+ Version : in String := "");
+ -- Register a passive package
+
+ generic
+ RCI_Name : String;
+ package RCI_Info is
+ function Get_RCI_Package_Receiver return Interfaces.Unsigned_64;
+ function Get_Active_Partition_ID return RPC.Partition_ID;
+ end RCI_Info;
+ -- RCI package information caching
+
+ procedure Run (Main : in 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 00000000000..11f265eb1e3
--- /dev/null
+++ b/gcc/ada/s-pooglo.adb
@@ -0,0 +1,98 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O O L _ G L O B A L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Pools; use System.Storage_Pools;
+with System.Storage_Elements;
+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
+ 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
+ begin
+ Memory.Free (Address);
+ end Deallocate;
+
+ ------------------
+ -- Storage_Size --
+ ------------------
+
+ function Storage_Size
+ (Pool : Unbounded_No_Reclaim_Pool)
+ return SSE.Storage_Count
+ is
+ 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 00000000000..c209e2d8da3
--- /dev/null
+++ b/gcc/ada/s-pooglo.ads
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O O L _ G L O B A L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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
+
+ -- Default pool in 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;
+
+ 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);
+
+ 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 for the compiler
+
+ 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 00000000000..6adbf2d33ca
--- /dev/null
+++ b/gcc/ada/s-pooloc.adb
@@ -0,0 +1,154 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O O L _ L O C A L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Memory;
+with System.Storage_Elements;
+with System.Address_To_Access_Conversions;
+
+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;
+ package Addr is new Address_To_Access_Conversions (Address);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Next (A : Address) return Acc_Address;
+ -- Given an address of a block, return an access to the next block
+
+ function Prev (A : Address) return Acc_Address;
+ -- 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
+ 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
+ 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 Acc_Address (Addr.To_Pointer (A));
+ end Next;
+
+ ----------
+ -- Prev --
+ ----------
+
+ function Prev (A : Address) return Acc_Address is
+ begin
+ return Acc_Address (Addr.To_Pointer (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 00000000000..4a76a2a3de3
--- /dev/null
+++ b/gcc/ada/s-pooloc.ads
@@ -0,0 +1,79 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O O L _ L O C A L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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
+
+ -- Default pool in the compiler for access types locally declared
+
+ 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 00000000000..fdcd93b1c27
--- /dev/null
+++ b/gcc/ada/s-poosiz.adb
@@ -0,0 +1,359 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . P O O L _ S I Z E --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+with System.Address_To_Access_Conversions;
+
+package body System.Pool_Size is
+
+ package SSE renames System.Storage_Elements;
+ use type SSE.Storage_Offset;
+
+ package SC is new Address_To_Access_Conversions (SSE.Storage_Count);
+
+ 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_sizS 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
+ 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 := SC.To_Pointer (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;
+ 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
+ if Pool.Elmt_Size = 0 then
+ Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
+
+ else
+ SC.To_Pointer (Address).all := Pool.First_Free;
+ Pool.First_Free := Address - Pool.The_Pool'Address + 1;
+ end if;
+ end Deallocate;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Pool : in out Stack_Bounded_Pool) is
+ 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 clause
+
+ 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 appropraite
+ -- 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
+ Align_Size : constant SSE.Storage_Count :=
+ ((Storage_Size + Alignment - 1) / Alignment) *
+ Alignment;
+ Chunk : 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
+ return SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all;
+ end Next;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next
+ (Pool : Stack_Bounded_Pool;
+ Chunk, Next : SSE.Storage_Count)
+ is
+ begin
+ SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next;
+ end Set_Next;
+
+ --------------
+ -- Set_Size --
+ --------------
+
+ procedure Set_Size
+ (Pool : Stack_Bounded_Pool;
+ Chunk, Size : SSE.Storage_Count)
+ is
+ begin
+ SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all := Size;
+ end Set_Size;
+
+ ----------
+ -- Size --
+ ----------
+
+ function Size
+ (Pool : Stack_Bounded_Pool;
+ Chunk : SSE.Storage_Count)
+ return SSE.Storage_Count
+ is
+ begin
+ return SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all;
+ 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 00000000000..ee5de8b9d9f
--- /dev/null
+++ b/gcc/ada/s-poosiz.ads
@@ -0,0 +1,88 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O O L _ S I Z E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..6cadc429609
--- /dev/null
+++ b/gcc/ada/s-powtab.ads
@@ -0,0 +1,74 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P O W T E N _ T A B L E --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a powers of ten table used for real conversions
+
+package System.Powten_Table is
+pragma Pure (Powten_Table);
+
+ 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.adb b/gcc/ada/s-proinf.adb
new file mode 100644
index 00000000000..a2f48a3f2cf
--- /dev/null
+++ b/gcc/ada/s-proinf.adb
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P R O G R A M _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..f54c72246cb
--- /dev/null
+++ b/gcc/ada/s-proinf.ads
@@ -0,0 +1,47 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P R O G R A M _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+-- This package contains the definitions and routines used as parameters
+-- to the run-time system at program startup.
+
+package System.Program_Info is
+
+ function Default_Task_Stack return Integer;
+ --
+ -- The default stack size for each created thread. This default value
+ -- can be overriden on a per-task basis by the language-defined
+ -- Storage_Size pragma.
+ --
+
+end System.Program_Info;
diff --git a/gcc/ada/s-rpc.adb b/gcc/ada/s-rpc.adb
new file mode 100644
index 00000000000..43f1fc0a8db
--- /dev/null
+++ b/gcc/ada/s-rpc.adb
@@ -0,0 +1,126 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . R P C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.27 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+package body System.RPC is
+
+ GNAT : constant Boolean := True;
+ -- This dummy entity allows the compiler to recognize that this is the
+ -- version of this package that is supplied by GNAT, not by the user.
+ -- This is used to cause a compile time error if an attempt is made to
+ -- use features in System.RPC that are only available from a true PCS.
+
+ 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";
+
+ pragma Warnings (Off);
+ -- Kill messages about out parameters not set
+
+ ----------
+ -- 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_Exception (Program_Error'Identity, Msg);
+ end Read;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : in out Params_Stream_Type;
+ Item : in Ada.Streams.Stream_Element_Array)
+ is
+ begin
+ Raise_Exception (Program_Error'Identity, Msg);
+ end Write;
+
+
+ ------------
+ -- Do_RPC --
+ ------------
+
+ procedure Do_RPC
+ (Partition : in Partition_ID;
+ Params : access Params_Stream_Type;
+ Result : access Params_Stream_Type)
+ is
+ begin
+ Raise_Exception (Program_Error'Identity, Msg);
+ end Do_RPC;
+
+ ------------
+ -- Do_APC --
+ ------------
+
+ procedure Do_APC
+ (Partition : in Partition_ID;
+ Params : access Params_Stream_Type)
+ is
+ begin
+ Raise_Exception (Program_Error'Identity, Msg);
+ end Do_APC;
+
+ ----------------------------
+ -- Establish_RPC_Receiver --
+ ----------------------------
+
+ procedure Establish_RPC_Receiver
+ (Partition : in Partition_ID;
+ Receiver : in RPC_Receiver)
+ is
+ 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 00000000000..63ab5480a9b
--- /dev/null
+++ b/gcc/ada/s-rpc.ads
@@ -0,0 +1,98 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . R P C --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.17 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 : in Ada.Streams.Stream_Element_Array);
+
+ -- Synchronous call
+
+ procedure Do_RPC
+ (Partition : in Partition_ID;
+ Params : access Params_Stream_Type;
+ Result : access Params_Stream_Type);
+
+ -- Asynchronous call
+
+ procedure Do_APC
+ (Partition : in 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 : in Partition_ID;
+ Receiver : in 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.ads b/gcc/ada/s-scaval.ads
new file mode 100644
index 00000000000..db121d20ba7
--- /dev/null
+++ b/gcc/ada/s-scaval.ads
@@ -0,0 +1,75 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . S C A L A R _ V A L U E S --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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
+pragma Pure (Scalar_Values);
+
+ type Byte1 is mod 2 ** 8;
+ type Byte2 is mod 2 ** 16;
+ type Byte4 is mod 2 ** 32;
+ type Byte8 is mod 2 ** 64;
+
+ IS_Is1 : constant Byte1; -- Initialize 1 byte signed value
+ IS_Is2 : constant Byte2; -- Initialize 2 byte signed value
+ IS_Is4 : constant Byte4; -- Initialize 4 byte signed value
+ IS_Is8 : constant Byte8; -- Initialize 8 byte signed value
+ IS_Iu1 : constant Byte1; -- Initialize 1 byte unsigned value
+ IS_Iu2 : constant Byte2; -- Initialize 2 byte unsigned value
+ IS_Iu4 : constant Byte4; -- Initialize 4 byte unsigned value
+ IS_Iu8 : constant Byte8; -- Initialize 8 byte unsigned value
+ IS_Isf : constant Short_Float; -- Initialize short float value
+ IS_Ifl : constant Float; -- Initialize float value
+ IS_Ilf : constant Long_Float; -- Initialize long float value
+ IS_Ill : constant Long_Long_Float; -- Initialize long long float value
+
+ pragma Import (Ada, IS_Is1, "__gnat_Is1");
+ pragma Import (Ada, IS_Is2, "__gnat_Is2");
+ pragma Import (Ada, IS_Is4, "__gnat_Is4");
+ pragma Import (Ada, IS_Is8, "__gnat_Is8");
+ pragma Import (Ada, IS_Iu1, "__gnat_Iu1");
+ pragma Import (Ada, IS_Iu2, "__gnat_Iu2");
+ pragma Import (Ada, IS_Iu4, "__gnat_Iu4");
+ pragma Import (Ada, IS_Iu8, "__gnat_Iu8");
+ pragma Import (Ada, IS_Isf, "__gnat_Isf");
+ pragma Import (Ada, IS_Ifl, "__gnat_Ifl");
+ pragma Import (Ada, IS_Ilf, "__gnat_Ilf");
+ pragma Import (Ada, IS_Ill, "__gnat_Ill");
+
+end System.Scalar_Values;
diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb
new file mode 100644
index 00000000000..ac3d9bb9081
--- /dev/null
+++ b/gcc/ada/s-secsta.adb
@@ -0,0 +1,376 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.49 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Soft_Links;
+with System.Parameters;
+with Unchecked_Conversion;
+with 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;
+
+ -- +------------------+
+ -- | Next |
+ -- +------------------+
+ -- | | Last (200)
+ -- | |
+ -- | |
+ -- | |
+ -- | |
+ -- | |
+ -- | | First (101)
+ -- +------------------+
+ -- +----------> | | |
+ -- | +----------+-------+
+ -- | | |
+ -- | ^ V
+ -- | | |
+ -- | +-------+----------+
+ -- | | | |
+ -- | +------------------+
+ -- | | | Last (100)
+ -- | | C |
+ -- | | H |
+ -- +-----------------+ | +-------->| U |
+ -- | Current_Chunk -|--+ | | N |
+ -- +-----------------+ | | K |
+ -- | Top -|-----+ | | First (1)
+ -- +-----------------+ +------------------+
+ -- | Default_Size | | Prev |
+ -- +-----------------+ +------------------+
+ --
+ --
+ type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
+
+ type Chunk_Id (First, Last : Mark_Id);
+ type Chunk_Ptr is access all Chunk_Id;
+
+ type Chunk_Id (First, Last : Mark_Id) is record
+ Prev, Next : Chunk_Ptr;
+ Mem : Memory (First .. Last);
+ end record;
+
+ type Stack_Id is record
+ Top : Mark_Id;
+ Default_Size : SSE.Storage_Count;
+ Current_Chunk : Chunk_Ptr;
+ end record;
+
+ type Fixed_Stack_Id is record
+ Top : Mark_Id;
+ Last : Mark_Id;
+ Mem : Memory (1 .. Mark_Id'Last / 2 - 1);
+ -- This should really be 1 .. Mark_Id'Last, but there is a bug in gigi
+ -- with this type, introduced Sep 2001, that causes gigi to reject this
+ -- type because its size in bytes overflows ???
+ end record;
+
+ type Stack_Ptr is access Stack_Id;
+ type Fixed_Stack_Ptr is access Fixed_Stack_Id;
+
+ function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr);
+ function To_Addr is new Unchecked_Conversion (Stack_Ptr, System.Address);
+ function To_Stack is new Unchecked_Conversion (Fixed_Stack_Ptr, Stack_Ptr);
+ function To_Fixed is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr);
+
+ procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
+
+ --------------
+ -- Allocate --
+ --------------
+
+ procedure SS_Allocate
+ (Address : out System.Address;
+ Storage_Size : SSE.Storage_Count)
+ is
+ Stack : constant Stack_Ptr :=
+ From_Addr (SSL.Get_Sec_Stack_Addr.all);
+ Fixed_Stack : Fixed_Stack_Ptr;
+ Chunk : Chunk_Ptr;
+ Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
+ Max_Size : constant Mark_Id :=
+ ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
+ * Max_Align;
+
+ Count_Unreleased_Chunks : Natural;
+ To_Be_Released_Chunk : Chunk_Ptr;
+
+ begin
+ -- If the secondary stack is fixed in the primary stack, then the
+ -- handling becomes simple
+
+ if not SS_Ratio_Dynamic then
+ Fixed_Stack := To_Fixed (Stack);
+
+ if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
+ raise Storage_Error;
+ end if;
+
+ Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
+ Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size);
+ return;
+ end if;
+
+ 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 eventally create the necessary room
+
+ Count_Unreleased_Chunks := 0;
+
+ 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 the default size unless it is not sufficient
+
+ elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
+ Chunk.Next := new Chunk_Id (
+ First => Chunk.Last + 1,
+ Last => Chunk.Last + Mark_Id (Stack.Default_Size));
+
+ Chunk.Next.Prev := Chunk;
+
+ 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
+
+ Address := Chunk.Mem (Stack.Top)'Address;
+ Stack.Top := Stack.Top + Max_Size;
+ Stack.Current_Chunk := Chunk;
+ end SS_Allocate;
+
+ -------------
+ -- SS_Free --
+ -------------
+
+ procedure SS_Free (Stk : in out System.Address) is
+ Stack : Stack_Ptr;
+ Chunk : Chunk_Ptr;
+
+ procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
+
+ begin
+ if not SS_Ratio_Dynamic then
+ return;
+ end if;
+
+ Stack := From_Addr (Stk);
+ 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 SS_Free;
+
+ -------------
+ -- SS_Info --
+ -------------
+
+ procedure SS_Info is
+ Stack : constant Stack_Ptr :=
+ From_Addr (SSL.Get_Sec_Stack_Addr.all);
+ Fixed_Stack : Fixed_Stack_Ptr;
+ Nb_Chunks : Integer := 1;
+ Chunk : Chunk_Ptr := Stack.Current_Chunk;
+
+ begin
+ Put_Line ("Secondary Stack information:");
+
+ if not SS_Ratio_Dynamic then
+ Fixed_Stack := To_Fixed (Stack);
+ Put_Line (
+ " Total size : "
+ & Mark_Id'Image (Fixed_Stack.Last)
+ & " bytes");
+ Put_Line (
+ " Current allocated space : "
+ & Mark_Id'Image (Fixed_Stack.Top - 1)
+ & " bytes");
+ return;
+ end if;
+
+ 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 : "
+ & Mark_Id'Image (Chunk.Last)
+ & " bytes");
+ Put_Line (
+ " Current allocated space : "
+ & Mark_Id'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 SS_Info;
+
+ -------------
+ -- SS_Init --
+ -------------
+
+ procedure SS_Init
+ (Stk : in out System.Address;
+ Size : Natural := Default_Secondary_Stack_Size)
+ is
+ Stack : Stack_Ptr;
+ Fixed_Stack : Fixed_Stack_Ptr;
+
+ begin
+ if not SS_Ratio_Dynamic then
+ Fixed_Stack := To_Fixed (From_Addr (Stk));
+ Fixed_Stack.Top := Fixed_Stack.Mem'First;
+
+ if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then
+ Fixed_Stack.Last := 0;
+ else
+ Fixed_Stack.Last := Mark_Id (Size) -
+ 2 * Mark_Id'Max_Size_In_Storage_Elements;
+ end if;
+
+ return;
+ end if;
+
+ Stack := new Stack_Id;
+ Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
+ Stack.Top := 1;
+ Stack.Default_Size := SSE.Storage_Count (Size);
+
+ Stk := To_Addr (Stack);
+ end SS_Init;
+
+ -------------
+ -- SS_Mark --
+ -------------
+
+ function SS_Mark return Mark_Id is
+ begin
+ return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top;
+ end SS_Mark;
+
+ ----------------
+ -- SS_Release --
+ ----------------
+
+ procedure SS_Release (M : Mark_Id) is
+ begin
+ From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ 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. Sun), and in any case it is a good idea for efficiency.
+
+ Stack : aliased Stack_Id;
+ for Stack'Alignment use Standard'Maximum_Alignment;
+
+ Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size);
+ for Chunk'Alignment use Standard'Maximum_Alignment;
+
+ Chunk_Address : System.Address;
+
+begin
+ if SS_Ratio_Dynamic then
+ Stack.Top := 1;
+ Stack.Current_Chunk := Chunk'Access;
+ Stack.Default_Size := Default_Secondary_Stack_Size;
+ System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
+
+ else
+ Chunk_Address := Chunk'Address;
+ SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
+ System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
+ end if;
+end System.Secondary_Stack;
diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads
new file mode 100644
index 00000000000..82d7e6cc50a
--- /dev/null
+++ b/gcc/ada/s-secsta.ads
@@ -0,0 +1,102 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.21 $
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+
+package System.Secondary_Stack is
+
+ package SSE renames System.Storage_Elements;
+
+ Default_Secondary_Stack_Size : constant := 10 * 1024;
+ -- Default size of a secondary stack
+
+ procedure SS_Init
+ (Stk : in out System.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 allocated 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
+ (Address : out System.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 'Address'
+
+ procedure SS_Free (Stk : in out System.Address);
+ -- Release the memory allocated for the Secondary Stack. That is to say,
+ -- all the allocated chuncks.
+ -- Upon return, Stk will be set to System.Null_Address
+
+ type Mark_Id is private;
+ -- Type used to mark the stack.
+
+ 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
+
+ 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 Mark_Id is new SSE.Integer_Address;
+
+end System.Secondary_Stack;
diff --git a/gcc/ada/s-sequio.adb b/gcc/ada/s-sequio.adb
new file mode 100644
index 00000000000..87c6d69ede7
--- /dev/null
+++ b/gcc/ada/s-sequio.adb
@@ -0,0 +1,160 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . S E Q U E N T I A L _ I O --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.File_IO;
+with 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
+ begin
+ return new Sequential_AFCB;
+ end AFCB_Allocate;
+
+ ----------------
+ -- AFCB_Close --
+ ----------------
+
+ -- No special processing required for Sequential_IO close
+
+ procedure AFCB_Close (File : access Sequential_AFCB) is
+ begin
+ null;
+ end AFCB_Close;
+
+ ---------------
+ -- AFCB_Free --
+ ---------------
+
+ procedure AFCB_Free (File : access Sequential_AFCB) is
+
+ type FCB_Ptr is access all Sequential_AFCB;
+
+ FT : FCB_Ptr := FCB_Ptr (File);
+
+ procedure Free is new
+ Unchecked_Deallocation (Sequential_AFCB, FCB_Ptr);
+
+ begin
+ Free (FT);
+ end AFCB_Free;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create
+ (File : in out File_Type;
+ Mode : in FCB.File_Mode := FCB.Out_File;
+ Name : in String := "";
+ Form : in String := "")
+ is
+ File_Control_Block : Sequential_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => 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 : in FCB.File_Mode;
+ Name : in String;
+ Form : in String := "")
+ is
+ File_Control_Block : Sequential_AFCB;
+
+ begin
+ FIO.Open (File_Ptr => AP (File),
+ Dummy_FCB => 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 : in 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 00000000000..445729073df
--- /dev/null
+++ b/gcc/ada/s-sequio.ads
@@ -0,0 +1,83 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . S E Q U E N T I A L _ I O --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the declaration of the control block used for
+-- Seqential_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 : access Sequential_AFCB);
+ procedure AFCB_Free (File : 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 : in 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 : in FCB.File_Mode := FCB.Out_File;
+ Name : in String := "";
+ Form : in String := "");
+
+ procedure Open
+ (File : in out File_Type;
+ Mode : in FCB.File_Mode;
+ Name : in String;
+ Form : in String := "");
+
+end System.Sequential_IO;
diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb
new file mode 100644
index 00000000000..5d0d45378c0
--- /dev/null
+++ b/gcc/ada/s-shasto.adb
@@ -0,0 +1,507 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+with Ada.IO_Exceptions;
+with Ada.Streams;
+with Ada.Streams.Stream_IO;
+
+with GNAT.HTable;
+with System.Global_Locks;
+with GNAT.OS_Lib;
+with GNAT.Task_Lock;
+
+use type GNAT.OS_Lib.String_Access;
+
+with System;
+with System.File_Control_Block;
+with System.File_IO;
+with Unchecked_Deallocation;
+with Unchecked_Conversion;
+
+package body System.Shared_Storage is
+
+ package AS renames Ada.Streams;
+
+ package OS renames GNAT.OS_Lib;
+
+ package IOX renames Ada.IO_Exceptions;
+
+ package FCB renames System.File_Control_Block;
+
+ package SFI renames System.File_IO;
+
+ package TSL renames GNAT.Task_Lock;
+
+ Dir : OS.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 : in 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 : OS.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 Unchecked_Deallocation
+ (Object => Shared_Var_File_Entry,
+ Name => Shared_Var_File_Entry_Ptr);
+
+ procedure Free is new Unchecked_Deallocation
+ (Object => File_Stream_Type'Class,
+ Name => File_Stream_Access);
+
+ function To_AFCB_Ptr is
+ new 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 : OS.String_Access) return Hash_Header;
+ function Equal (F1, F2 : OS.String_Access) return Boolean;
+ -- Hash and equality functions for hash table
+
+ package SFT is new GNAT.HTable.Simple_HTable
+ (Header_Num => Hash_Header,
+ Element => Shared_Var_File_Entry_Ptr,
+ No_Element => null,
+ Key => OS.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.
+
+ ---------------
+ -- 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);
+ OS.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 : OS.String_Access) return Boolean is
+ begin
+ return F1.all = F2.all;
+ end Equal;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : OS.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
+ begin
+ if Dir = null then
+ Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
+ 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 : in SIO.Stream_Access) is
+ begin
+ TSL.Unlock;
+ end Shared_Var_Close;
+
+ ---------------------
+ -- Shared_Var_Lock --
+ ---------------------
+
+ procedure Shared_Var_Lock (Var : in String) is
+ begin
+ TSL.Lock;
+ Initialize;
+
+ if Lock_Count /= 0 then
+ Lock_Count := Lock_Count + 1;
+ TSL.Unlock;
+
+ else
+ Lock_Count := 1;
+ TSL.Unlock;
+ System.Global_Locks.Acquire_Lock (Global_Lock);
+ end if;
+
+ exception
+ when others =>
+ TSL.Unlock;
+ raise;
+ end Shared_Var_Lock;
+
+ ----------------------
+ -- 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
+ TSL.Lock;
+ 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);
+ TSL.Unlock;
+ 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 =>
+ TSL.Unlock;
+ raise;
+ end Shared_Var_ROpen;
+
+ -----------------------
+ -- Shared_Var_Unlock --
+ -----------------------
+
+ procedure Shared_Var_Unlock (Var : in String) is
+ begin
+ TSL.Lock;
+ Initialize;
+ Lock_Count := Lock_Count - 1;
+
+ if Lock_Count = 0 then
+ System.Global_Locks.Release_Lock (Global_Lock);
+ end if;
+ TSL.Unlock;
+
+ exception
+ when others =>
+ TSL.Unlock;
+ 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
+ TSL.Lock;
+ 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 =>
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity,
+ "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 =>
+ TSL.Unlock;
+ raise;
+ end Shared_Var_WOpen;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : in out File_Stream_Type;
+ Item : in 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 00000000000..d1b5e819edc
--- /dev/null
+++ b/gcc/ada/s-shasto.ads
@@ -0,0 +1,220 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package manages the shared/persistant storage required for
+-- full implementation of variables in Shared_Passive packages, more
+-- precisely variables whose enclosing dynamic scope is a shared
+-- passive package. This implementation is specific to GNAT and GLADE
+-- provides a more general implementation not dedicated to file
+-- storage.
+
+-- --------------------------
+-- -- Shared Storage Model --
+-- --------------------------
+
+-- The basic model used is that each partition that references the
+-- Shared_Passive package has a local copy of the package data that
+-- is initialized in accordance with the declarations of the package
+-- in the normal manner. The routines in System.Shared_Storage are
+-- then used to ensure that the values in these separate copies are
+-- properly synchronized with the state of the overall system.
+
+-- In the GNAT implementation, this synchronization is ensured by
+-- maintaining a set of files, in a designated directory. The
+-- directory is designated by setting the environment variable
+-- SHARED_MEMORY_DIRECTORY. This variable must be set for all
+-- partitions. If the environment variable is not defined, then the
+-- current directory is used.
+
+-- There is one storage for each variable. The name is the fully
+-- qualified name of the variable with all letters forced to lower
+-- case. For example, the variable Var in the shared passive package
+-- Pkg results in the storage name pkg.var.
+
+-- If the storage does not exist, it indicates that no partition has
+-- assigned a new value, so that the initial value is the correct
+-- one. This is the critical component of the model. It means that
+-- there is no system-wide synchronization required for initializing
+-- the package, since the shared storages need not (and do not)
+-- reflect the initial state. There is therefore no issue of
+-- synchronizing initialization and read/write access.
+
+-- -----------------------
+-- -- Read/Write Access --
+-- -----------------------
+
+-- The approach is as follows:
+
+-- For each shared variable, var, an access routine varR is created whose
+-- body has the following form (this example is for Pkg.Var):
+
+-- procedure varR is
+-- S : Ada.Streams.Stream_IO.Stream_Access;
+-- begin
+-- S := Shared_Var_ROpen ("pkg.var");
+-- if S /= null then
+-- typ'Read (S);
+-- Shared_Var_Close (S);
+-- end if;
+-- end varR;
+
+-- The routine Shared_Var_ROpen in package System.Shared_Storage
+-- either returns null if the storage does not exist, or otherwise a
+-- Stream_Access value that references the corresponding shared
+-- storage, ready to read the current value.
+
+-- Each reference to the shared variable, var, is preceded by a
+-- call to the corresponding varR procedure, which either leaves the
+-- initial value unchanged if the storage does not exist, or reads
+-- the current value from the shared storage.
+
+-- In addition, for each shared variable, var, an assignment routine
+-- is created whose body has the following form (again for Pkg.Var)
+
+-- procedure VarA is
+-- S : Ada.Streams.Stream_IO.Stream_Access;
+-- begin
+-- S := Shared_Var_WOpen ("pkg.var");
+-- typ'Write (S, var);
+-- Shared_Var_Close (S);
+-- end VarA;
+
+-- The routine Shared_Var_WOpen in package System.Shared_Storage
+-- returns a Stream_Access value that references the corresponding
+-- shared storage, ready to write the new value.
+
+-- Each assignment to the shared variable, var, is followed by a call
+-- to the corresponding varA procedure, which writes the new value to
+-- the shared storage.
+
+-- Note that there is no general synchronization for these storage
+-- read and write operations, since it is assumed that a correctly
+-- operating programs will provide appropriate synchronization. In
+-- particular, variables can be protected using protected types with
+-- no entries.
+
+-- The routine Shared_Var_Close is called to indicate the end of a
+-- read/write operations. This can be useful even in the context of
+-- the GNAT implementation. For instance, when a read operation and a
+-- write operation occur at the same time on the same partition, as
+-- the same stream is used simultaneously, both operations can
+-- terminate abruptly by raising exception Mode_Error because the
+-- stream has been opened in read mode and then in write mode and at
+-- least used by the read opartion. To avoid this unexpected
+-- behaviour, we introduce a synchronization at the partition level.
+
+-- 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).
+
+with Ada.Streams.Stream_IO;
+
+package System.Shared_Storage is
+
+ package SIO renames Ada.Streams.Stream_IO;
+
+ 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 : in 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.
+
+ 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 obtaind by a
+ -- prior call to the Shared_Mem_Lock procedure, and is to be
+ -- generated as the last operation in the body of a protected
+ -- subprogram.
+
+end System.Shared_Storage;
diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb
new file mode 100644
index 00000000000..518c14ca7f0
--- /dev/null
+++ b/gcc/ada/s-soflin.adb
@@ -0,0 +1,368 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S O F T _ L I N K S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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.Machine_State_Operations; use System.Machine_State_Operations;
+-- Used for Create_TSD, Destroy_TSD
+
+with System.Parameters;
+-- Used for Sec_Stack_Ratio
+
+with System.Secondary_Stack;
+
+package body System.Soft_Links is
+
+ package SST renames System.Secondary_Stack;
+
+ -- Allocate an exception stack for the main program to use.
+ -- We make sure that the stack has maximum alignment. Some systems require
+ -- this (e.g. Sun), and in any case it is a good idea for efficiency.
+
+ NT_Exc_Stack : array (0 .. 8192) of aliased Character;
+ for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
+
+ NT_TSD : 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;
+
+ ---------------------------
+ -- 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;
+
+ New_TSD.Machine_State_Addr :=
+ System.Address
+ (System.Machine_State_Operations.Allocate_Machine_State);
+ 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);
+ System.Machine_State_Operations.Free_Machine_State
+ (Machine_State (Old_TSD.Machine_State_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_TSD.Exc_Stack_Addr;
+ 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_Machine_State_Addr_NT --
+ -------------------------------
+
+ function Get_Machine_State_Addr_NT return Address is
+ begin
+ return NT_TSD.Machine_State_Addr;
+ end Get_Machine_State_Addr_NT;
+
+ ---------------------------------
+ -- Get_Machine_State_Addr_Soft --
+ ---------------------------------
+
+ function Get_Machine_State_Addr_Soft return Address is
+ begin
+ return Get_Machine_State_Addr.all;
+ end Get_Machine_State_Addr_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_Adafinal --
+ -------------------
+
+ procedure Null_Adafinal is
+ begin
+ null;
+ end Null_Adafinal;
+
+ ---------------------------
+ -- Set_Exc_Stack_Addr_NT --
+ ---------------------------
+
+ procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address) is
+ begin
+ NT_TSD.Exc_Stack_Addr := Addr;
+ end Set_Exc_Stack_Addr_NT;
+
+ -----------------------------
+ -- Set_Exc_Stack_Addr_Soft --
+ -----------------------------
+
+ procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address) is
+ begin
+ Set_Exc_Stack_Addr (Self_ID, Addr);
+ end Set_Exc_Stack_Addr_Soft;
+
+ ---------------------------
+ -- 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_Machine_State_Addr_NT --
+ -------------------------------
+
+ procedure Set_Machine_State_Addr_NT (Addr : Address) is
+ begin
+ NT_TSD.Machine_State_Addr := Addr;
+ end Set_Machine_State_Addr_NT;
+
+ ---------------------------------
+ -- Set_Machine_State_Addr_Soft --
+ ---------------------------------
+
+ procedure Set_Machine_State_Addr_Soft (Addr : Address) is
+ begin
+ Set_Machine_State_Addr (Addr);
+ end Set_Machine_State_Addr_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_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;
+
+ -------------------------
+ -- Package Elaboration --
+ -------------------------
+
+begin
+ NT_TSD.Exc_Stack_Addr := NT_Exc_Stack (8192)'Address;
+ Ada.Exceptions.Save_Occurrence
+ (NT_TSD.Current_Excep, Ada.Exceptions.Null_Occurrence);
+
+end System.Soft_Links;
diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads
new file mode 100644
index 00000000000..52306076ad1
--- /dev/null
+++ b/gcc/ada/s-soflin.ads
@@ -0,0 +1,365 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S O F T _ L I N K S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.15 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains a set of subprogram access variables that access
+-- some low-level primitives that are called different depending wether
+-- 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 all the time, we use a system of soft links where the links are
+-- initialized to non-tasking versions, and then if the tasking is
+-- initialized, they are reset to the real tasking versions.
+
+with Ada.Exceptions;
+with System.Stack_Checking;
+
+package System.Soft_Links is
+ pragma Elaborate_Body;
+
+ 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;
+ type Addr_Param_Proc is access procedure (Addr : Address);
+
+ type Get_Address_Call is access function return Address;
+ type Set_Address_Call is access procedure (Addr : Address);
+ type Set_Address_Call2 is access procedure
+ (Self_ID : Address; Addr : Address);
+
+ type Get_Integer_Call is access function return Integer;
+ type Set_Integer_Call is access procedure (Len : Integer);
+
+ type Get_EOA_Call is access function return EOA;
+ type Set_EOA_Call is access procedure (Excep : EOA);
+ type Set_EO_Call is access procedure (Excep : EO);
+
+ type Special_EO_Call is access
+ procedure (Excep : EO := Current_Target_Exception);
+
+ type Timed_Delay_Call is access
+ procedure (Time : Duration; Mode : Integer);
+
+ type Get_Stack_Access_Call is access
+ function return Stack_Checking.Stack_Access;
+
+ -- Suppress checks on all these types, since we know corrresponding
+ -- 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, 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);
+
+ -- 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;
+
+ -- Declarations for the no tasking versions of the required routines
+
+ procedure Abort_Defer_NT;
+ -- Defer task abortion (non-tasking case, does nothing)
+
+ procedure Abort_Undefer_NT;
+ -- Undefer task abortion (non-tasking case, does nothing)
+
+ procedure Abort_Handler_NT;
+ -- Handle task abortion (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
+ -- which 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 Null_Adafinal;
+ -- Shuts down the runtime system (non-tasking no-finalization case,
+ -- does nothing)
+
+ Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
+ pragma Suppress (Access_Check, Abort_Defer);
+ -- Defer task abortion (task/non-task case as appropriate)
+
+ Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
+ pragma Suppress (Access_Check, Abort_Undefer);
+ -- Undefer task abortion (task/non-task case as appropriate)
+
+ Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
+ -- Handle task abortion (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.
+
+ Adafinal : No_Param_Proc := Null_Adafinal'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_Machine_State_Addr_NT return Address;
+ procedure Set_Machine_State_Addr_NT (Addr : Address);
+
+ Get_Machine_State_Addr : Get_Address_Call
+ := Get_Machine_State_Addr_NT'Access;
+ Set_Machine_State_Addr : Set_Address_Call
+ := Set_Machine_State_Addr_NT'Access;
+
+ function Get_Exc_Stack_Addr_NT return Address;
+ procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address);
+ -- Self_ID is a Task_ID, but in the non-tasking case there is no
+ -- Task_ID type available, so make do with Address.
+
+ Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
+ Set_Exc_Stack_Addr : Set_Address_Call2 := Set_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;
+
+ -------------------------------------
+ -- 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) that is 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.
+
+ Jmpbuf_Address : Address := 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 : Address := Null_Address;
+ -- Address of currently allocated secondary stack
+
+ Exc_Stack_Addr : Address := Null_Address;
+ -- Address of a task-specific stack used for the propagation of
+ -- exceptions in response to synchronous faults. This alternate
+ -- stack is necessary when propagating Storage_Error resulting
+ -- from a stack overflow, as the task's primary stack is full.
+ -- This is currently only used on the SGI, and this value stays
+ -- null on other platforms.
+
+ 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.
+
+ Machine_State_Addr : Address := Null_Address;
+ --
+ 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;
+ procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address);
+ pragma Inline (Get_Exc_Stack_Addr_Soft);
+ pragma Inline (Set_Exc_Stack_Addr_Soft);
+
+ function Get_Machine_State_Addr_Soft return Address;
+ procedure Set_Machine_State_Addr_Soft (Addr : Address);
+ pragma Inline (Get_Machine_State_Addr_Soft);
+ pragma Inline (Set_Machine_State_Addr_Soft);
+
+end System.Soft_Links;
diff --git a/gcc/ada/s-sopco3.adb b/gcc/ada/s-sopco3.adb
new file mode 100644
index 00000000000..43da8388bbd
--- /dev/null
+++ b/gcc/ada/s-sopco3.adb
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..a102cbbef89
--- /dev/null
+++ b/gcc/ada/s-sopco3.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the function for concatenating three strings
+
+package System.String_Ops_Concat_3 is
+pragma Pure (String_Ops_Concat_3);
+
+ function Str_Concat_3 (S1, S2, S3 : String) return String;
+ -- Concatenate two 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 00000000000..136f7e4d9b3
--- /dev/null
+++ b/gcc/ada/s-sopco4.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 _ 4 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..fdda3e10fb0
--- /dev/null
+++ b/gcc/ada/s-sopco4.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the function for concatenating four strings
+
+package System.String_Ops_Concat_4 is
+pragma Pure (String_Ops_Concat_4);
+
+ function Str_Concat_4 (S1, S2, S3, S4 : String) return String;
+ -- Concatenate two 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 00000000000..991d6e42381
--- /dev/null
+++ b/gcc/ada/s-sopco5.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 _ 5 --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..0da0886b4d3
--- /dev/null
+++ b/gcc/ada/s-sopco5.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the function for concatenating five strings
+
+package System.String_Ops_Concat_5 is
+pragma Pure (String_Ops_Concat_5);
+
+ function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String;
+ -- Concatenate two 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 00000000000..3a5e5b3176a
--- /dev/null
+++ b/gcc/ada/s-stache.adb
@@ -0,0 +1,282 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+
+with System.Storage_Elements; use System.Storage_Elements;
+with System.Parameters; use System.Parameters;
+with System.Soft_Links;
+
+package body System.Stack_Checking is
+
+ Kilobyte : constant Storage_Offset := 1024;
+ Default_Env_Stack_Size : constant Storage_Offset := 8000 * Kilobyte;
+ -- This size is assumed for the environment stack when no size has been
+ -- set by the runtime, and no GNAT_STACK_LIMIT environment variable was
+ -- present. The value is chosen to be just under 8 MB whic is the actual
+ -- default size on some systems including LinuxThreads, so we will get
+ -- correct storage errors on those systems without setting environment
+ -- variables.
+
+ function Set_Stack_Info (Stack : 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 like VxWorks and OS/2 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.
+
+ -- The following constants should be imported from some system-specific
+ -- constants package. The constants must be static for performance reasons.
+
+ ----------------------------
+ -- Invalidate_Stack_Cache --
+ ----------------------------
+
+ procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
+ begin
+ Cache := Null_Stack;
+ end Invalidate_Stack_Cache;
+
+ --------------------
+ -- Set_Stack_Info --
+ --------------------
+
+ function Set_Stack_Info
+ (Stack : access Stack_Access)
+ return Stack_Access
+ is
+ type Frame_Mark is null record;
+ Frame_Location : Frame_Mark;
+ Frame_Address : Address := Frame_Location'Address;
+
+ My_Stack : Stack_Access;
+ Limit_Chars : System.Address;
+ Limit : Integer;
+
+ function getenv (S : String) return System.Address;
+ pragma Import (C, getenv, External_Name => "getenv");
+
+ function atoi (A : System.Address) return Integer;
+ pragma Import (C, atoi);
+
+ 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 := Default_Env_Stack_Size;
+
+ -- When the environment variable GNAT_STACK_LIMIT is set,
+ -- set Environment_Stack_Size to that number of kB.
+
+ Limit_Chars := getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
+
+ if Limit_Chars /= Null_Address then
+ Limit := atoi (Limit_Chars);
+ if Limit >= 0 then
+ My_Stack.Size := Storage_Offset (Limit) * Kilobyte;
+ end if;
+ end if;
+ end if;
+
+ My_Stack.Base := 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;
+
+ return My_Stack; -- Never trust the cached value, but return local copy!
+ end Set_Stack_Info;
+
+ --------------------
+ -- Set_Stack_Size --
+ --------------------
+
+ -- Specify the stack size for the current frame.
+
+ procedure Set_Stack_Size
+ (Stack_Size : System.Storage_Elements.Storage_Offset)
+ is
+ My_Stack : Stack_Access;
+ Frame_Address : constant System.Address := My_Stack'Address;
+
+ begin
+ My_Stack := Stack_Check (Frame_Address);
+
+ if Stack_Grows_Down then
+ My_Stack.Limit := My_Stack.Base - Stack_Size;
+ else
+ My_Stack.Limit := My_Stack.Base + Stack_Size;
+ end if;
+ end Set_Stack_Size;
+
+ -----------------
+ -- 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
+ -- 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
+ Stack_Address > Cached_Stack.Limit))
+ or else
+ (not Stack_Grows_Down and then
+ (Frame_Address >= Cached_Stack.Base
+ and
+ 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 : 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 initializing
+ -- Base 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
+ Ada.Exceptions.Raise_Exception
+ (E => Storage_Error'Identity,
+ Message => "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;
diff --git a/gcc/ada/s-stache.ads b/gcc/ada/s-stache.ads
new file mode 100644
index 00000000000..d95c7021a54
--- /dev/null
+++ b/gcc/ada/s-stache.ads
@@ -0,0 +1,107 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a system-independent implementation of stack
+-- checking using comparison with stack base and limit.
+
+with System.Storage_Elements;
+
+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 is
+ 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
+
+ ----------------------
+ -- Client Interface --
+ ----------------------
+
+ procedure Set_Stack_Size
+ (Stack_Size : System.Storage_Elements.Storage_Offset);
+ -- Specify the stack size for the current task.
+
+ 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.
+
+ 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.
+
+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.
+
+ 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;
diff --git a/gcc/ada/s-stalib.adb b/gcc/ada/s-stalib.adb
new file mode 100644
index 00000000000..71fb5ccffc3
--- /dev/null
+++ b/gcc/ada/s-stalib.adb
@@ -0,0 +1,90 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.17 $
+-- --
+-- Copyright (C) 1995-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 Warnings (Off);
+-- Kill warnings from unused withs
+
+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 System.Soft_Links;
+-- Referenced directly from generated code
+-- Also referenced from exception handling routines.
+-- This is needed for programs that don't use exceptions explicitely 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
+
+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.
+
+ Inside_Elab_Final_Code : Integer := 0;
+ pragma Export (C, Inside_Elab_Final_Code, "__gnat_inside_elab_final_code");
+ -- ???This variable is obsolete starting from 29/08 but cannot be removed
+ -- ???right away due to the bootstrap problems
+
+ --------------------------
+ -- 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;
+
+end System.Standard_Library;
diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads
new file mode 100644
index 00000000000..cfd6622158f
--- /dev/null
+++ b/gcc/ada/s-stalib.ads
@@ -0,0 +1,250 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.43 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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, an 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 the definitions of all the standard 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 Polling (Off);
+-- We must turn polling off for this unit, because otherwise we get
+-- elaboration circularities with Ada.Exceptions if polling is on.
+
+with System;
+with Unchecked_Conversion;
+
+package System.Standard_Library is
+
+ pragma Suppress (All_Checks);
+ -- Suppress explicitely all the checks to work around the Solaris linker
+ -- bug when using gnatmake -f -a (but without -gnatp). This is not needed
+ -- with Solaris 2.6, so eventually can be removed ???
+
+ type Big_String_Ptr is access all String (Positive);
+ -- A non-fat pointer type for null terminated strings
+
+ function To_Ptr is
+ new 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 Exception_Data;
+ type Exception_Data_Ptr is access all Exception_Data;
+ -- An equivalent of Exception_Id that is public
+
+ -- The following record defines the underlying representation of exceptions
+
+ -- WARNING! Any changes to this may need to be reflectd 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 : Big_String_Ptr;
+ -- Fully expanded name of exception, null terminated
+
+ 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 : Integer;
+ -- 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).
+
+ end record;
+
+ -- Definitions for standard predefined exceptions defined in Standard,
+
+ -- Why are the Nul's 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 => To_Ptr (Constraint_Error_Name'Address),
+ HTable_Ptr => null,
+ Import_Code => 0);
+
+ Numeric_Error_Def : aliased Exception_Data :=
+ (Not_Handled_By_Others => False,
+ Lang => 'A',
+ Name_Length => Numeric_Error_Name'Length,
+ Full_Name => To_Ptr (Numeric_Error_Name'Address),
+ HTable_Ptr => null,
+ Import_Code => 0);
+
+ Program_Error_Def : aliased Exception_Data :=
+ (Not_Handled_By_Others => False,
+ Lang => 'A',
+ Name_Length => Program_Error_Name'Length,
+ Full_Name => To_Ptr (Program_Error_Name'Address),
+ HTable_Ptr => null,
+ Import_Code => 0);
+
+ Storage_Error_Def : aliased Exception_Data :=
+ (Not_Handled_By_Others => False,
+ Lang => 'A',
+ Name_Length => Storage_Error_Name'Length,
+ Full_Name => To_Ptr (Storage_Error_Name'Address),
+ HTable_Ptr => null,
+ Import_Code => 0);
+
+ Tasking_Error_Def : aliased Exception_Data :=
+ (Not_Handled_By_Others => False,
+ Lang => 'A',
+ Name_Length => Tasking_Error_Name'Length,
+ Full_Name => To_Ptr (Tasking_Error_Name'Address),
+ HTable_Ptr => null,
+ Import_Code => 0);
+
+ Abort_Signal_Def : aliased Exception_Data :=
+ (Not_Handled_By_Others => True,
+ Lang => 'A',
+ Name_Length => Abort_Signal_Name'Length,
+ Full_Name => To_Ptr (Abort_Signal_Name'Address),
+ HTable_Ptr => null,
+ Import_Code => 0);
+
+ 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-stoele.adb b/gcc/ada/s-stoele.adb
new file mode 100644
index 00000000000..b469ad208b7
--- /dev/null
+++ b/gcc/ada/s-stoele.adb
@@ -0,0 +1,88 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+package body System.Storage_Elements is
+
+ pragma Suppress (All_Checks);
+
+ function To_Address is new Unchecked_Conversion (Storage_Offset, Address);
+ function To_Offset is new Unchecked_Conversion (Address, Storage_Offset);
+
+ -- Address arithmetic
+
+ function "+" (Left : Address; Right : Storage_Offset) return Address is
+ begin
+ return Left + To_Address (Right);
+ end "+";
+
+ function "+" (Left : Storage_Offset; Right : Address) return Address is
+ begin
+ return To_Address (Left) + Right;
+ end "+";
+
+ function "-" (Left : Address; Right : Storage_Offset) return Address is
+ begin
+ return Left - To_Address (Right);
+ end "-";
+
+ function "-" (Left, Right : Address) return Storage_Offset is
+ begin
+ return To_Offset (Left - Right);
+ end "-";
+
+ function "mod" (Left : Address; Right : Storage_Offset)
+ return Storage_Offset is
+ begin
+ if Right >= 0 then
+ return Storage_Offset (Address'(Left mod Address (Right)));
+ else
+ return -Storage_Offset (Address'(Left mod Address (-Right)));
+ end if;
+ end "mod";
+
+ -- Conversion to/from integers
+
+ function To_Address (Value : Integer_Address) return Address is
+ begin
+ return Address (Value);
+ end To_Address;
+
+ function To_Integer (Value : Address) return Integer_Address is
+ begin
+ return Integer_Address (Value);
+ end To_Integer;
+
+end System.Storage_Elements;
diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads
new file mode 100644
index 00000000000..18a170b0b2d
--- /dev/null
+++ b/gcc/ada/s-stoele.ads
@@ -0,0 +1,91 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.23 $ --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 Warnings (Off);
+-- This is to stop bootstrap problems with the use of Inline_Always
+-- To be removed (along with redundant Inline pragmas) in 3.13.
+
+package System.Storage_Elements is
+pragma Pure (Storage_Elements);
+-- Note that we take advantage of the implementation permission to make
+-- this unit Pure instead of Preelaborable; see RM 13.7.1(15).
+
+ type Storage_Offset is range
+ -(2 ** (Standard."-" (Standard'Address_Size, 1))) ..
+ +(2 ** (Standard."-" (Standard'Address_Size, 1))) - 1;
+ -- Note: the reason for the qualification of "-" here by Standard is
+ -- that we have a current bug in GNAT that otherwise causes a bogus
+ -- ambiguity when this unit is analyzed in an Rtsfind context.
+
+ 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;
+
+ 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 ("+");
+ pragma Inline_Always ("+");
+
+ function "+" (Left : Storage_Offset; Right : Address) return Address;
+ pragma Convention (Intrinsic, "+");
+ pragma Inline ("+");
+ pragma Inline_Always ("+");
+
+ function "-" (Left : Address; Right : Storage_Offset) return Address;
+ pragma Convention (Intrinsic, "-");
+ pragma Inline ("-");
+ pragma Inline_Always ("-");
+
+ function "-" (Left, Right : Address) return Storage_Offset;
+ pragma Convention (Intrinsic, "-");
+ pragma Inline ("-");
+ pragma Inline_Always ("-");
+
+ function "mod"
+ (Left : Address;
+ Right : Storage_Offset)
+ return Storage_Offset;
+ pragma Convention (Intrinsic, "mod");
+ pragma Inline ("mod");
+ pragma Inline_Always ("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 (To_Address);
+ pragma Inline_Always (To_Address);
+
+ function To_Integer (Value : Address) return Integer_Address;
+ pragma Convention (Intrinsic, To_Integer);
+ pragma Inline (To_Integer);
+ pragma Inline_Always (To_Integer);
+
+end System.Storage_Elements;
diff --git a/gcc/ada/s-stopoo.ads b/gcc/ada/s-stopoo.ads
new file mode 100644
index 00000000000..b6982e357f5
--- /dev/null
+++ b/gcc/ada/s-stopoo.ads
@@ -0,0 +1,71 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.15 $ --
+-- --
+-- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+with System.Storage_Elements;
+
+package System.Storage_Pools is
+ pragma Preelaborate (System.Storage_Pools);
+
+ 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 : in System.Storage_Elements.Storage_Count;
+ Alignment : in System.Storage_Elements.Storage_Count)
+ is abstract;
+
+ procedure Deallocate
+ (Pool : in out Root_Storage_Pool;
+ Storage_Address : in Address;
+ Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
+ Alignment : in System.Storage_Elements.Storage_Count)
+ is abstract;
+
+ function Storage_Size
+ (Pool : Root_Storage_Pool)
+ return System.Storage_Elements.Storage_Count
+ is abstract;
+
+private
+ type Root_Storage_Pool is abstract
+ new Ada.Finalization.Limited_Controlled with null record;
+end System.Storage_Pools;
diff --git a/gcc/ada/s-stratt.adb b/gcc/ada/s-stratt.adb
new file mode 100644
index 00000000000..83964752bb7
--- /dev/null
+++ b/gcc/ada/s-stratt.adb
@@ -0,0 +1,674 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME 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 --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with Ada.Streams; use Ada.Streams;
+with 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 AI195-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 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);
+
+ -- 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_C is new UC (Character, S_C);
+ 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);
+
+ -- 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_C is new UC (S_C, Character);
+ 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);
+
+ ----------
+ -- I_AD --
+ ----------
+
+ function I_AD (Stream : 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 : 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 : 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 : 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 To_C (T);
+ end if;
+ end I_C;
+
+ ---------
+ -- I_F --
+ ---------
+
+ function I_F (Stream : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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;
+
+ ----------
+ -- W_AD --
+ ----------
+
+ procedure W_AD (Stream : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in Character) is
+ T : constant S_C := From_C (Item);
+
+ begin
+ Ada.Streams.Write (Stream.all, T);
+ end W_C;
+
+ ---------
+ -- W_F --
+ ---------
+
+ procedure W_F (Stream : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in 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 : access RST; Item : in Wide_Character) is
+ T : constant S_WC := From_WC (Item);
+
+ begin
+ Ada.Streams.Write (Stream.all, T);
+ end W_WC;
+
+end System.Stream_Attributes;
diff --git a/gcc/ada/s-stratt.ads b/gcc/ada/s-stratt.ads
new file mode 100644
index 00000000000..66f617bedac
--- /dev/null
+++ b/gcc/ada/s-stratt.ads
@@ -0,0 +1,194 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME 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 --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc.
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Stream_Attributes);
+
+ 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;
+
+ -- 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 : access RST) return Fat_Pointer;
+ function I_AS (Stream : access RST) return Thin_Pointer;
+ function I_B (Stream : access RST) return Boolean;
+ function I_C (Stream : access RST) return Character;
+ function I_F (Stream : access RST) return Float;
+ function I_I (Stream : access RST) return Integer;
+ function I_LF (Stream : access RST) return Long_Float;
+ function I_LI (Stream : access RST) return Long_Integer;
+ function I_LLF (Stream : access RST) return Long_Long_Float;
+ function I_LLI (Stream : access RST) return Long_Long_Integer;
+ function I_LLU (Stream : access RST) return UST.Long_Long_Unsigned;
+ function I_LU (Stream : access RST) return UST.Long_Unsigned;
+ function I_SF (Stream : access RST) return Short_Float;
+ function I_SI (Stream : access RST) return Short_Integer;
+ function I_SSI (Stream : access RST) return Short_Short_Integer;
+ function I_SSU (Stream : access RST) return UST.Short_Short_Unsigned;
+ function I_SU (Stream : access RST) return UST.Short_Unsigned;
+ function I_U (Stream : access RST) return UST.Unsigned;
+ function I_WC (Stream : access RST) return 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 : access RST; Item : in Fat_Pointer);
+ procedure W_AS (Stream : access RST; Item : in Thin_Pointer);
+ procedure W_B (Stream : access RST; Item : in Boolean);
+ procedure W_C (Stream : access RST; Item : in Character);
+ procedure W_F (Stream : access RST; Item : in Float);
+ procedure W_I (Stream : access RST; Item : in Integer);
+ procedure W_LF (Stream : access RST; Item : in Long_Float);
+ procedure W_LI (Stream : access RST; Item : in Long_Integer);
+ procedure W_LLF (Stream : access RST; Item : in Long_Long_Float);
+ procedure W_LLI (Stream : access RST; Item : in Long_Long_Integer);
+ procedure W_LLU (Stream : access RST; Item : in UST.Long_Long_Unsigned);
+ procedure W_LU (Stream : access RST; Item : in UST.Long_Unsigned);
+ procedure W_SF (Stream : access RST; Item : in Short_Float);
+ procedure W_SI (Stream : access RST; Item : in Short_Integer);
+ procedure W_SSI (Stream : access RST; Item : in Short_Short_Integer);
+ procedure W_SSU (Stream : access RST; Item : in UST.Short_Short_Unsigned);
+ procedure W_SU (Stream : access RST; Item : in UST.Short_Unsigned);
+ procedure W_U (Stream : access RST; Item : in UST.Unsigned);
+ procedure W_WC (Stream : access RST; Item : in Wide_Character);
+
+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 (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);
+
+end System.Stream_Attributes;
diff --git a/gcc/ada/s-strops.adb b/gcc/ada/s-strops.adb
new file mode 100644
index 00000000000..35dac03383b
--- /dev/null
+++ b/gcc/ada/s-strops.adb
@@ -0,0 +1,149 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . S T R I N G _ O P S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+
+ ---------------
+ -- Str_Equal --
+ ---------------
+
+ function Str_Equal (A, B : String) return Boolean is
+ begin
+ if A'Length /= B'Length then
+ return False;
+
+ else
+ for J in A'Range loop
+ if A (J) /= B (J + (B'First - A'First)) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end Str_Equal;
+
+ -------------------
+ -- Str_Normalize --
+ -------------------
+
+ procedure Str_Normalize (A : in out String) is
+ begin
+ for J in A'Range loop
+ A (J) := Character'Last;
+ end loop;
+ end Str_Normalize;
+
+ ------------------------
+ -- Wide_Str_Normalize --
+ ------------------------
+
+ procedure Wide_Str_Normalize (A : in out Wide_String) is
+ begin
+ for J in A'Range loop
+ A (J) := Wide_Character'Last;
+ end loop;
+ end Wide_Str_Normalize;
+
+end System.String_Ops;
diff --git a/gcc/ada/s-strops.ads b/gcc/ada/s-strops.ads
new file mode 100644
index 00000000000..9a2846f75e3
--- /dev/null
+++ b/gcc/ada/s-strops.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . S T R I N G _ O P S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime operations on strings
+
+package System.String_Ops is
+pragma Pure (String_Ops);
+
+ 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
+
+ function Str_Equal (A, B : String) return Boolean;
+ -- Compare two strings for equality
+
+ procedure Str_Normalize (A : in out String);
+ -- Initialize String object if pragma Normalize_Scalars is in effect.
+
+ procedure Wide_Str_Normalize (A : in out Wide_String);
+ -- Ditto for Wide_String.
+
+ pragma Inline (Str_Normalize);
+ pragma Inline (Wide_Str_Normalize);
+end System.String_Ops;
diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb
new file mode 100644
index 00000000000..1f75f741feb
--- /dev/null
+++ b/gcc/ada/s-taasde.adb
@@ -0,0 +1,384 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+-- Used for Raise_Exception
+
+with System.Task_Primitives.Operations;
+-- Used for Write_Lock,
+-- Unlock,
+-- Self,
+-- Monotonic_Clock,
+-- Self,
+-- Timed_Sleep,
+-- Wakeup,
+-- Yield
+
+with System.Tasking.Utilities;
+-- Used for Make_Independent
+
+with System.Tasking.Initialization;
+-- Used for Defer_Abort
+-- Undefer_Abort
+
+with System.Tasking.Debug;
+-- Used for Trace
+
+with System.OS_Primitives;
+-- used for Max_Sensible_Delay
+
+with Ada.Task_Identification;
+-- used for Task_ID type
+
+with Unchecked_Conversion;
+
+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;
+
+ function To_System is new 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);
+ 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);
+ STI.Undefer_Abort_Nestable (D.Self_Id);
+ end Cancel_Async_Delay;
+
+ ---------------------------
+ -- Enqueue_Time_Duration --
+ ---------------------------
+
+ function Enqueue_Duration
+ (T : in Duration;
+ D : Delay_Block_Access)
+ return Boolean
+ is
+ begin
+ if T <= 0.0 then
+ D.Timed_Out := True;
+ STPO.Yield;
+ return False;
+
+ else
+ 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
+ Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
+ "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;
+
+ STI.Defer_Abort (Self_Id);
+ 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);
+ STI.Undefer_Abort (Self_Id);
+ 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
+ Next_Wakeup_Time : Duration := Duration'Last;
+ Timedout : Boolean;
+ Yielded : Boolean;
+ Now : Duration;
+ Dequeued,
+ Tpred,
+ Tsucc : Delay_Block_Access;
+ Dequeued_Task : Task_ID;
+
+ -- Initialize_Timer_Queue returns null, but has critical side-effects
+ -- of initializing the timer queue.
+
+ begin
+ Timer_Server_ID := STPO.Self;
+ STU.Make_Independent;
+
+ -- 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);
+ 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 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.
+
+ 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);
+ STI.Undefer_Abort (Timer_Server_ID);
+ end loop;
+ end Timer_Server;
+
+ ------------------------------
+ -- Package Body Elaboration --
+ ------------------------------
+
+begin
+ Timer_Queue.Succ := Timer_Queue'Unchecked_Access;
+ Timer_Queue.Pred := Timer_Queue'Unchecked_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 00000000000..f83c7222f38
--- /dev/null
+++ b/gcc/ada/s-taasde.ads
@@ -0,0 +1,154 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1998-1999 Ada Core Technologies, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the procedures to implements timeouts (delays) on
+-- 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 : in 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, abortion 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 00000000000..acf479c4359
--- /dev/null
+++ b/gcc/ada/s-tadeca.adb
@@ -0,0 +1,58 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- E N Q U E U E _ C A L E N D A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1998-1999 Ada Core Technologies, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Calendar.Delays;
+with System.Task_Primitives.Operations;
+with System.Tasking.Initialization;
+
+function System.Tasking.Async_Delays.Enqueue_Calendar
+ (T : in 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 00000000000..cf0a9180d17
--- /dev/null
+++ b/gcc/ada/s-tadeca.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- E N Q U E U E _ C A L E N D A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1998-1999 Ada Core Technologies, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 : in 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 00000000000..a44a810adff
--- /dev/null
+++ b/gcc/ada/s-tadert.adb
@@ -0,0 +1,59 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- E N Q U E U E _ R T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1998-1999 Ada Core Technologies, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : in 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 00000000000..12e3e592f80
--- /dev/null
+++ b/gcc/ada/s-tadert.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- E N Q U E U E _ R T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1998-1999 Ada Core Technologies, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 : in 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 00000000000..bf9afbaedad
--- /dev/null
+++ b/gcc/ada/s-taenca.adb
@@ -0,0 +1,713 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.36 $
+-- --
+-- Copyright (C) 1991-2001, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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
+
+with System.Task_Primitives.Operations;
+-- used for STPO.Write_Lock
+-- Unlock
+-- STPO.Get_Priority
+-- Sleep
+-- Timed_Sleep
+
+with System.Tasking.Initialization;
+-- used for Change_Base_Priority
+-- Poll_Base_Priority_Change_At_Entry_Call
+-- Dynamic_Priority_Support
+-- Defer_Abort/Undefer_Abort
+
+with System.Tasking.Protected_Objects.Entries;
+-- used for To_Protection
+
+with System.Tasking.Protected_Objects.Operations;
+-- used for PO_Service_Entries
+
+with System.Tasking.Queuing;
+-- used for Requeue_Call_With_New_Prio
+-- Onqueue
+-- Dequeue_Call
+
+with System.Tasking.Utilities;
+-- used for Exit_One_ATC_Level
+
+package body System.Tasking.Entry_Calls is
+
+ package STPO renames System.Task_Primitives.Operations;
+
+ use System.Task_Primitives;
+ use System.Tasking.Protected_Objects.Entries;
+ use System.Tasking.Protected_Objects.Operations;
+
+ -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
+ -- internally. Those operations will raise Program_Error, which
+ -- we do 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.
+
+ procedure Unlock_Server (Entry_Call : Entry_Call_Link);
+ -- STPO.Unlock the server targeted by Entry_Call. The server must
+ -- be locked before calling this.
+
+ 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.
+
+ procedure Check_Pending_Actions_For_Entry_Call
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link);
+ pragma Inline (Check_Pending_Actions_For_Entry_Call);
+ -- This procedure performs priority change of a queued call and
+ -- dequeuing of an entry call when an the call is cancelled.
+ -- If the call is dequeued the state should be set to Cancelled.
+
+ 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);
+ -- Has to be called with the Self_ID's ATCB write-locked.
+ -- May temporariliy release the lock.
+
+ ---------------------
+ -- 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.
+
+ procedure Check_Exception
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link)
+ is
+ 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 --
+ -----------------------------------------
+
+ -- 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 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);
+
+ if Entry_Call.Cancellation_Attempted then
+ Entry_Call.State := Cancelled;
+ else
+ Entry_Call.State := Done;
+ end if;
+
+ 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 --
+ -----------------
+
+ -- This should only be called by the Entry_Call.Self.
+ -- It should be holding no other ATCB locks at the time.
+
+ 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.
+
+ STPO.Yield;
+
+ else
+ 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.STPO.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 : Task_ID := STPO.Self;
+ Old_Base_Priority : System.Any_Priority;
+
+ begin
+ 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);
+
+ -- 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);
+ 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 --
+ ---------------------------------------------
+
+ -- A specialized version of Poll_Base_Priority_Change,
+ -- that does the optional entry queue reordering.
+
+ procedure Poll_Base_Priority_Change_At_Entry_Call
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link)
+ is
+ begin
+ if Initialization.Dynamic_Priority_Support
+ and then Self_ID.Pending_Priority_Change
+ then
+ -- Check for ceiling violations ???
+
+ Self_ID.Pending_Priority_Change := False;
+
+ if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then
+ STPO.Unlock (Self_ID);
+ STPO.Yield;
+ STPO.Write_Lock (Self_ID);
+
+ else
+ if Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then
+
+ -- Raising priority
+
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+
+ else
+ -- Lowering priority
+
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ STPO.Unlock (Self_ID);
+ STPO.Yield;
+ STPO.Write_Lock (Self_ID);
+ end if;
+ end if;
+
+ -- Requeue the entry call at the new priority.
+ -- We need to requeue even if the new priority is the same than
+ -- the previous (see ACVC 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 --
+ --------------------
+
+ -- Reset the priority of a task completing an accept statement to
+ -- the value it had before the call.
+
+ procedure Reset_Priority
+ (Acceptor_Prev_Priority : Rendezvous_Priority;
+ Acceptor : Task_ID) is
+ begin
+ if Acceptor_Prev_Priority /= Priority_Not_Boosted then
+ STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority,
+ Loss_Of_Inheritance => True);
+ end if;
+ end Reset_Priority;
+
+ -- ???
+ -- Check why we don't need any kind of lock to do this.
+ -- Do we limit this kind of "active" priority change to be done
+ -- by the task for itself only?
+
+ ------------------------------
+ -- Try_To_Cancel_Entry_Call --
+ ------------------------------
+
+ -- This is used to implement the Cancel_Task_Entry_Call and
+ -- Cancel_Protected_Entry_Call.
+ -- Try to cancel async. entry call.
+ -- Effect includes Abort_To_Level and Wait_For_Completion.
+ -- Cancelled = True iff the cancelation 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 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_X_Entry_Call is called.
+ -- That may indicate an error. Find out what is going on. ???
+
+ pragma Assert (Entry_Call.Mode = Asynchronous_Call);
+ pragma Assert (Self_ID = Self);
+
+ Initialization.Defer_Abort_Nestable (Self_ID);
+ 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 (Self_ID, Entry_Call);
+ STPO.Unlock (Self_ID);
+ Succeeded := Entry_Call.State = Cancelled;
+
+ if Succeeded then
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+ else
+ -- ????
+
+ 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 possiblility 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 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);
+
+ if Called_PO.Pending_Action then
+ Called_PO.Pending_Action := False;
+ Caller := STPO.Self;
+ STPO.Write_Lock (Caller);
+ Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
+ Initialization.Change_Base_Priority (Caller);
+ STPO.Unlock (Caller);
+ end if;
+
+ Unlock_Entries (Called_PO);
+ 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;
+ STPO.Write_Lock (Caller);
+ Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
+ Initialization.Change_Base_Priority (Caller);
+ STPO.Unlock (Caller);
+ end if;
+
+ Unlock_Entries (Called_PO);
+ end if;
+ end Unlock_Server;
+
+ -------------------------
+ -- Wait_For_Completion--
+ -------------------------
+
+ -- Call this only when holding Self_ID locked
+
+ -- If this is a conditional call, it should be cancelled when it
+ -- becomes abortable. This is checked in the loop below.
+
+ -- We do the same thing for Asynchronous_Call. Executing the following
+ -- loop will clear the Pending_Action field if there is no
+ -- Pending_Action. We want the call made from Cancel_Task_Entry_Call
+ -- to check the abortion level so that we make sure that the Cancelled
+ -- field reflect the status of an Asynchronous_Call properly.
+ -- This problem came up when the triggered statement and the abortable
+ -- part depend on entries of the same task. When a cancellation is
+ -- delivered, Undefer_Abort in the call made from abortable part
+ -- sets the Pending_Action bit to false. However, the call is actually
+ -- made to cancel the Asynchronous Call so that we need to check its
+ -- status here again. Otherwise we may end up waiting for a cancelled
+ -- call forever.
+
+ -- ????? .........
+ -- Recheck the logic of the above old comment. It may be stale.
+
+ procedure Wait_For_Completion
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link)
+ is
+ begin
+ pragma Assert (Self_ID = Entry_Call.Self);
+ Self_ID.Common.State := Entry_Caller_Sleep;
+
+ 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);
+ end Wait_For_Completion;
+
+ --------------------------------------
+ -- Wait_For_Completion_With_Timeout --
+ --------------------------------------
+
+ -- This routine will lock Self_ID.
+
+ -- 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.
+
+ procedure Wait_For_Completion_With_Timeout
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link;
+ Wakeup_Time : Duration;
+ Mode : Delay_Modes)
+ is
+ Timedout : Boolean := False;
+ Yielded : Boolean := False;
+
+ use type Ada.Exceptions.Exception_Id;
+
+ begin
+ Initialization.Defer_Abort_Nestable (Self_ID);
+ STPO.Write_Lock (Self_ID);
+
+ pragma Assert (Entry_Call.Self = Self_ID);
+ pragma Assert (Entry_Call.Mode = Timed_Call);
+ 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 the same loop in the
+ -- ordinary Wait_For_Completion, above.
+
+ 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
+
+ -- Try to cancel the call (see Try_To_Cancel_Entry_Call for
+ -- corresponding code in the ATC case).
+
+ 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;
+
+ -- 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);
+
+ STPO.Unlock (Self_ID);
+
+ if Entry_Call.State = Cancelled then
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+ else
+ -- ????
+
+ 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 possiblility 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
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+ end loop;
+
+ Entry_Calls.Check_Exception (Self_ID, Entry_Call);
+ end if;
+ end if;
+
+ 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.
+
+ Self_ID.Common.State := Runnable;
+ Utilities.Exit_One_ATC_Level (Self_ID);
+ STPO.Unlock (Self_ID);
+
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+
+ if not Yielded then
+ STPO.Yield;
+ end if;
+ end Wait_For_Completion_With_Timeout;
+
+ --------------------------
+ -- Wait_Until_Abortable --
+ --------------------------
+
+ -- Wait to start the abortable part of an async. select statement
+ -- until the trigger entry call becomes 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);
+
+ 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);
+ end Wait_Until_Abortable;
+
+ -- It might seem that we should be holding the server's lock when
+ -- we test Call.State above.
+
+ -- In an earlier version, the code above temporarily unlocked the
+ -- caller and locked the server just for checking Call.State.
+ -- The unlocking of the caller risked missing a wakeup
+ -- (an error) and locking the server had no apparent value.
+ -- We should not need the server's lock, since once Call.State
+ -- is set to Was_Abortable or beyond, it never goes back below
+ -- Was_Abortable until this task starts another entry call.
+
+ -- ????
+ -- It seems that other calls to Lock_Server may also risk missing
+ -- wakeups. We need to check that they do not have this problem.
+
+end System.Tasking.Entry_Calls;
diff --git a/gcc/ada/s-taenca.ads b/gcc/ada/s-taenca.ads
new file mode 100644
index 00000000000..e28ff7a3e76
--- /dev/null
+++ b/gcc/ada/s-taenca.ads
@@ -0,0 +1,95 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.12 $ --
+-- --
+-- Copyright (C) 1991-1998, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System.Tasking.Entry_Calls is
+
+ procedure Wait_For_Completion
+ (Self_ID : Task_ID;
+ 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_ID locked.
+
+ procedure Wait_For_Completion_With_Timeout
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link;
+ Wakeup_Time : Duration;
+ Mode : Delay_Modes);
+ -- Same as Wait_For_Completion but it wait for a timeout with the value
+ -- specified in Wakeup_Time as well.
+ -- Self_ID will be locked by 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.
+
+ 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 cancelation 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_Prev_Priority : Rendezvous_Priority;
+ Acceptor : Task_ID);
+ pragma Inline (Reset_Priority);
+ -- Reset the priority of a task completing an accept statement to
+ -- the value it had before the call.
+
+ 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 00000000000..13149004416
--- /dev/null
+++ b/gcc/ada/s-taprob.adb
@@ -0,0 +1,127 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.79 $
+-- --
+-- Copyright (C) 1991-2001 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+-- used for Write_Lock
+-- Unlock
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+package body System.Tasking.Protected_Objects is
+
+ use Ada.Exceptions;
+ use System.Task_Primitives.Operations;
+
+ -------------------------
+ -- 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);
+ end Initialize_Protection;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock (Object : Protection_Access) is
+ Ceiling_Violation : Boolean;
+ begin
+ -- The lock is made without defering abortion.
+
+ -- Therefore the abortion 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 abortion, and compiler
+ -- generated calls must be protected with cleanup handlers to ensure
+ -- that abortion is undeferred in all cases.
+
+ Write_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ Raise_Exception (Program_Error'Identity, "Ceiling Violation");
+ end if;
+ end Lock;
+
+ --------------------
+ -- Lock_Read_Only --
+ --------------------
+
+ procedure Lock_Read_Only (Object : Protection_Access) is
+ Ceiling_Violation : Boolean;
+ begin
+ Read_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ Raise_Exception (Program_Error'Identity, "Ceiling Violation");
+ end if;
+ end Lock_Read_Only;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (Object : Protection_Access) is
+ begin
+ Unlock (Object.L'Access);
+ end Unlock;
+
+end System.Tasking.Protected_Objects;
diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads
new file mode 100644
index 00000000000..b1aafd0e423
--- /dev/null
+++ b/gcc/ada/s-taprob.ads
@@ -0,0 +1,225 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.35 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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
+
+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 _init_proc (_init : in out poTV) is
+ -- begin
+ -- _init.open := false;
+ -- _init_proc (_init._object);
+ -- initialize_protection (_init._object'unchecked_access,
+ -- unspecified_priority);
+ -- return;
+ -- end _init_proc;
+ -- ]
+ -- po : poT;
+ -- _init_proc (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;
+
+ 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 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;
+ Ceiling : System.Any_Priority;
+ end record;
+ pragma Volatile (Protection);
+ for Protection'Alignment use Standard'Maximum_Alignment;
+ -- Needed so that we can uncheck convert a Protection_Access to a
+ -- Protection_Entries_Access.
+
+ procedure Finalize_Protection (Object : in out Protection);
+ -- Clean up a Protection object; in particular, finalize the associated
+ -- Lock object. The compiler generates automatically calls to this
+ -- procedure
+
+end System.Tasking.Protected_Objects;
diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads
new file mode 100644
index 00000000000..19f035c4b9a
--- /dev/null
+++ b/gcc/ada/s-taprop.ads
@@ -0,0 +1,476 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.40 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains all the GNULL primitives that interface directly
+-- with the underlying OS.
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Task_ID
+
+with System.OS_Interface;
+-- used for Thread_Id
+
+package System.Task_Primitives.Operations is
+
+ pragma Elaborate_Body;
+ package ST renames System.Tasking;
+ package OSI renames System.OS_Interface;
+
+ procedure Initialize (Environment_Task : ST.Task_ID);
+ pragma Inline (Initialize);
+ -- 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 abortion 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,
+ All_Attrs_Level,
+ All_Tasks_Level,
+ Interrupts_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 : access Lock);
+ procedure Initialize_Lock (L : 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 L
+ -- 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 : access Lock);
+ procedure Finalize_Lock (L : 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 : access Lock; Ceiling_Violation : out Boolean);
+ procedure Write_Lock (L : access RTS_Lock);
+ 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 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 : 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 : access Lock);
+ procedure Unlock (L : access RTS_Lock);
+ 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.)
+
+ -- 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 whould give terrible performance on systems where
+ -- this has the effect of masking hardware interrupts, though we
+ -- could get away with 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 a
+ -- 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 a
+ -- ceiling violation.
+
+ 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 the 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);
+ -- Implements the semantics of the delay statement. It is assumed that
+ -- the caller is not abort-deferred and does 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);
+ -- returns 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;
+ -- returns the thread id of the specified task.
+
+ --------------------
+ -- 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 a
+ -- 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.
+
+ -----------------------------------------
+ -- 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
+ -- such functionality, unless the thread associated with T is
+ -- Thread_Self.
+ -- Such functionnality is needed by gdb on some targets (e.g VxWorks)
+ -- Return True is the operation is successful
+
+ 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 functionnality is needed by gdb on some targets (e.g VxWorks)
+ -- Return True is the operation is successful
+
+ procedure Lock_All_Tasks_List;
+ procedure Unlock_All_Tasks_List;
+ -- Lock/Unlock the All_Tasks_L lock which protects
+ -- System.Initialization.All_Tasks_List and Known_Tasks
+ -- ??? These routines were previousely in System.Tasking.Initialization
+ -- but were moved here to avoid dependency problems. That would be
+ -- nice to look at it some day and put it back in Initialization.
+
+end System.Task_Primitives.Operations;
diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb
new file mode 100644
index 00000000000..a6cf274c8ef
--- /dev/null
+++ b/gcc/ada/s-tarest.adb
@@ -0,0 +1,548 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 System.Parameters;
+-- used for Size_Type
+
+with System.Task_Info;
+-- used for Task_Info_Type
+-- Task_Image_Type
+
+with System.Task_Primitives.Operations;
+-- used for Enter_Task
+-- Write_Lock
+-- Unlock
+-- Wakeup
+-- Get_Priority
+
+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.
+
+with System.Secondary_Stack;
+-- used for SS_Init;
+
+with System.Storage_Elements;
+-- used for Storage_Array;
+
+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 System.Task_Primitives;
+ use System.Task_Primitives.Operations;
+ use System.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 --
+ -----------------------------------------------------------------
+
+ 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_Jmpbuf_Address return Address;
+ procedure Set_Jmpbuf_Address (Addr : Address);
+
+ function Get_Sec_Stack_Addr return Address;
+ procedure Set_Sec_Stack_Addr (Addr : Address);
+
+ function Get_Machine_State_Addr return Address;
+ procedure Set_Machine_State_Addr (Addr : Address);
+
+ function Get_Current_Excep return SSL.EOA;
+
+ procedure Timed_Delay_T (Time : Duration; Mode : Integer);
+
+ ------------------------
+ -- 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.
+
+ ---------------
+ -- Task_Lock --
+ ---------------
+
+ procedure Task_Lock is
+ begin
+ STPO.Write_Lock (Global_Task_Lock'Access);
+ end Task_Lock;
+
+ -----------------
+ -- Task_Unlock --
+ -----------------
+
+ procedure Task_Unlock is
+ begin
+ STPO.Unlock (Global_Task_Lock'Access);
+ end Task_Unlock;
+
+ ----------------------
+ -- Soft-Link Bodies --
+ ----------------------
+
+ function Get_Current_Excep return SSL.EOA is
+ begin
+ return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
+ end Get_Current_Excep;
+
+ function Get_Jmpbuf_Address return Address is
+ begin
+ return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
+ end Get_Jmpbuf_Address;
+
+ function Get_Machine_State_Addr return Address is
+ begin
+ return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
+ end Get_Machine_State_Addr;
+
+ function Get_Sec_Stack_Addr return Address is
+ begin
+ return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
+ end Get_Sec_Stack_Addr;
+
+ procedure Set_Jmpbuf_Address (Addr : Address) is
+ begin
+ STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
+ end Set_Jmpbuf_Address;
+
+ procedure Set_Machine_State_Addr (Addr : Address) is
+ begin
+ STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
+ end Set_Machine_State_Addr;
+
+ procedure Set_Sec_Stack_Addr (Addr : Address) is
+ begin
+ STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
+ end Set_Sec_Stack_Addr;
+
+ ------------------
+ -- 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);
+
+ -- Do not delete this variable.
+ -- In some targets, we need this variable to implement a fast Self.
+
+ use type System.Parameters.Size_Type;
+ 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);
+ Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
+
+ 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);
+ Terminate_Task (Self_ID);
+
+ exception -- not needed in no exc mode
+ when others => -- not needed in no exc mode
+ Terminate_Task (Self_ID); -- not needed in no exc mode
+ end;
+ end Task_Wrapper;
+
+ -------------------
+ -- Timed_Delay_T --
+ -------------------
+
+ procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
+ begin
+ STPO.Timed_Delay (STPO.Self, Time, Mode);
+ end Timed_Delay_T;
+
+ -----------------------
+ -- 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);
+
+ -- 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);
+
+ if C.Common.Base_Priority < Get_Priority (Self_ID) then
+ Activate_Prio := Get_Priority (Self_ID);
+ else
+ Activate_Prio := C.Common.Base_Priority;
+ end if;
+
+ 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);
+
+ -- 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
+ 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);
+
+ -- 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;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : System.Task_Info.Task_Image_Type;
+ Created_Task : out Task_ID)
+ is
+ T : Task_ID;
+ Self_ID : constant Task_ID := STPO.Self;
+ Base_Priority : System.Any_Priority;
+ Success : Boolean;
+
+ begin
+ if Priority = Unspecified_Priority then
+ Base_Priority := Self_ID.Common.Base_Priority;
+ else
+ Base_Priority := System.Any_Priority (Priority);
+ end if;
+
+ T := New_ATCB (0);
+ 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,
+ Task_Info, Size, T, 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);
+ raise Program_Error;
+ end if;
+
+ T.Entry_Calls (1).Self := T;
+ T.Common.Task_Image := Task_Image;
+ Unlock (Self_ID);
+
+ -- 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;
+ Created_Task := T;
+ 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);
+
+ Write_Lock (Self_ID);
+ Sleep (Self_ID, Master_Completion_Sleep);
+ Unlock (Self_ID);
+
+ -- 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
+ -- 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.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.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
+ SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
+ SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
+ SSL.Get_Current_Excep := Get_Current_Excep'Access;
+ SSL.Timed_Delay := Timed_Delay_T'Access;
+ SSL.Adafinal := Finalize_Global_Tasks'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);
+ SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+ 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 00000000000..7846fbc3233
--- /dev/null
+++ b/gcc/ada/s-tarest.ads
@@ -0,0 +1,211 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.5 $
+-- --
+-- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+-- used for Task_Info_Type
+
+with System.Parameters;
+-- used for Size_Type
+
+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;
+ -- end record;
+ -- procedure tB (_task : access tV);
+ -- freeze tV [
+ -- procedure _init_proc (_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_restricted_task (unspecified_priority, tZ,
+ -- unspecified_task_info, task_procedure_access!(tB'address),
+ -- _init'address, tE'unchecked_access, _chain, _task_id, _init.
+ -- _task_id);
+ -- return;
+ -- end _init_proc;
+ -- ]
+ --
+ -- _chain : aliased activation_chain;
+ -- _init_proc (_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);
+ -- t1I : task_image_type := new string'"t1";
+ -- _init_proc (t1, 3, _chain, t1I, 1);
+ --
+ -- activate_restricted_tasks (_chain'unchecked_access);
+
+ procedure Create_Restricted_Task
+ (Priority : Integer;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : System.Task_Info.Task_Image_Type;
+ Created_Task : out 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)
+ -- 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.
+ -- 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 sucessfully 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 pointer to 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 failed.
+
+ 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 00000000000..83e2efcc645
--- /dev/null
+++ b/gcc/ada/s-tasdeb.adb
@@ -0,0 +1,704 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.23 $
+-- --
+-- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package encapsulates all direct interfaces to task debugging services
+-- that are needed by gdb with gnat mode (1.13 and higher)
+
+-- 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 resticted (ravenscar) environments.
+
+with System.Task_Info,
+ System.Task_Primitives.Operations,
+ Unchecked_Conversion;
+
+package body System.Tasking.Debug is
+
+ use Interfaces.C;
+
+ package STPO renames System.Task_Primitives.Operations;
+
+ type Integer_Address is mod 2 ** Standard'Address_Size;
+ type Integer_Address_Ptr is access all Integer_Address;
+
+ function "+" is new
+ Unchecked_Conversion (System.Address, Integer_Address_Ptr);
+
+ function "+" is new
+ Unchecked_Conversion (Task_ID, Integer_Address);
+
+ Hex_Address_Width : constant := (Standard'Address_Size / 4);
+
+ Zero_Pos : constant := Character'Pos ('0');
+
+ Hex_Digits : constant array (0 .. Integer_Address'(15)) of Character :=
+ "0123456789abcdef";
+
+ subtype Buf_Range is Integer range 1 .. 80;
+ type Buf_Array is array (Buf_Range) of aliased Character;
+
+ type Buffer is record
+ Next : Buf_Range := Buf_Range'First;
+ Chars : Buf_Array := (Buf_Range => ' ');
+ end record;
+
+ type Buffer_Ptr is access all Buffer;
+
+ type Trace_Flag_Set is array (Character) of Boolean;
+
+ Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Put
+ (T : ST.Task_ID;
+ Width : Integer;
+ Buffer : Buffer_Ptr);
+ -- Put TCB pointer T, (coded in hexadecimal) into Buffer
+ -- right-justififed in Width characters.
+
+ procedure Put
+ (N : Integer_Address;
+ Width : Integer;
+ Buffer : Buffer_Ptr);
+ -- Put N (coded in decimal) into Buf right-justified in Width
+ -- characters starting at Buf (Next).
+
+ procedure Put
+ (S : String;
+ Width : Integer;
+ Buffer : Buffer_Ptr);
+ -- Put string S into Buf left-justified in Width characters
+ -- starting with space in Buf (Next), truncated as necessary.
+
+ procedure Put
+ (C : Character;
+ Buffer : Buffer_Ptr);
+ -- Put character C into Buf, left-justified, starting at Buf (Next)
+
+ procedure Space (Buffer : Buffer_Ptr);
+ -- Increment Next, resulting in a space
+
+ procedure Space
+ (N : Integer;
+ Buffer : Buffer_Ptr);
+ -- Increment Next by N, resulting in N spaces
+
+ procedure Clear (Buffer : Buffer_Ptr);
+ -- Clear Buf and reset Next to 1
+
+ procedure Write_Buf (Buffer : Buffer_Ptr);
+ -- Write contents of Buf (1 .. Next) to standard output
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Buffer : Buffer_Ptr) is
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+
+ begin
+ Buf := (Buf_Range => ' ');
+ Next := 1;
+ end Clear;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (T : ST.Task_ID) return String is
+ Buf : aliased Buffer;
+ Result : String (1 .. Hex_Address_Width + 21);
+
+ use type System.Task_Info.Task_Image_Type;
+
+ begin
+ Clear (Buf'Unchecked_Access);
+ Put (T, Hex_Address_Width, Buf'Unchecked_Access);
+ Put (':', Buf'Unchecked_Access);
+ Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+
+ if T.Common.Task_Image = null then
+ Put ("", 15, Buf'Unchecked_Access);
+ else
+ Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
+ end if;
+
+ for J in Result'Range loop
+ Result (J) := Buf.Chars (J);
+ end loop;
+
+ return Result;
+ end Image;
+
+ ----------------
+ -- List_Tasks --
+ ----------------
+
+ procedure List_Tasks is
+ C : ST.Task_ID;
+
+ begin
+ Print_Task_Info_Header;
+ C := All_Tasks_List;
+
+ while C /= null loop
+ Print_Task_Info (C);
+ C := C.Common.All_Tasks_Link;
+ end loop;
+ end List_Tasks;
+
+ -----------------------
+ -- Print_Accept_Info --
+ -----------------------
+
+ procedure Print_Accept_Info (T : ST.Task_ID) is
+ Buf : aliased Buffer;
+
+ begin
+ if T.Open_Accepts = null then
+ return;
+ end if;
+
+ Clear (Buf'Unchecked_Access);
+ Space (10, Buf'Unchecked_Access);
+ Put ("accepting:", 11, Buf'Unchecked_Access);
+
+ for J in T.Open_Accepts.all'Range loop
+ Put (Integer_Address (T.Open_Accepts (J).S), 3, Buf'Unchecked_Access);
+ end loop;
+
+ Write_Buf (Buf'Unchecked_Access);
+ end Print_Accept_Info;
+
+ ------------------------
+ -- 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 : ST.Task_ID) is
+ Entry_Call : Entry_Call_Link;
+ Buf : aliased Buffer;
+
+ use type System.Task_Info.Task_Image_Type;
+
+ begin
+ Clear (Buf'Unchecked_Access);
+ Put (T, Hex_Address_Width, Buf'Unchecked_Access);
+ Put (':', Buf'Unchecked_Access);
+ Put (' ', Buf'Unchecked_Access);
+ Put (':', Buf'Unchecked_Access);
+
+ if T = null then
+ Put (" null task", 10, Buf'Unchecked_Access);
+ Write_Buf (Buf'Unchecked_Access);
+ return;
+ end if;
+
+ Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+
+ if T.Common.Task_Image = null then
+ Put ("", 15, Buf'Unchecked_Access);
+ else
+ Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
+ end if;
+
+ Space (Buf'Unchecked_Access);
+ Put (Task_States'Image (T.Common.State), 10, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+
+ if T.Callable then
+ Put ('C', Buf'Unchecked_Access);
+ else
+ Space (Buf'Unchecked_Access);
+ end if;
+
+ if T.Open_Accepts /= null then
+ Put ('A', Buf'Unchecked_Access);
+ else
+ Space (Buf'Unchecked_Access);
+ end if;
+
+ if T.Common.Call /= null then
+ Put ('C', Buf'Unchecked_Access);
+ else
+ Space (Buf'Unchecked_Access);
+ end if;
+
+ if T.Terminate_Alternative then
+ Put ('T', Buf'Unchecked_Access);
+ else
+ Space (Buf'Unchecked_Access);
+ end if;
+
+ if T.Aborting then
+ Put ('A', Buf'Unchecked_Access);
+ else
+ Space (Buf'Unchecked_Access);
+ end if;
+
+ if T.Deferral_Level = 0 then
+ Space (3, Buf'Unchecked_Access);
+ else
+ Put ('D', Buf'Unchecked_Access);
+ if T.Deferral_Level < 0 then
+ Put ("<0", 2, Buf'Unchecked_Access);
+ elsif T.Deferral_Level > 1 then
+ Put (Integer_Address (T.Deferral_Level), 2, Buf'Unchecked_Access);
+ else
+ Space (2, Buf'Unchecked_Access);
+ end if;
+ end if;
+
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.Master_of_Task), 1, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.Master_Within), 1, Buf'Unchecked_Access);
+ Put (',', Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.Awake_Count), 1, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.Alive_Count), 1, Buf'Unchecked_Access);
+ Put (',', Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.ATC_Nesting_Level), 1, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.Pending_ATC_Level), 1, Buf'Unchecked_Access);
+ Put (',', Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.Common.Wait_Count), 1, Buf'Unchecked_Access);
+ Put (',', Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (Integer_Address (T.User_State), 1, Buf'Unchecked_Access);
+ Write_Buf (Buf'Unchecked_Access);
+
+ if T.Common.Call /= null then
+ Entry_Call := T.Common.Call;
+ Clear (Buf'Unchecked_Access);
+ Space (10, Buf'Unchecked_Access);
+ Put ("serving:", 8, Buf'Unchecked_Access);
+
+ while Entry_Call /= null loop
+ Put (Integer_Address
+ (Entry_Call.Self.Serial_Number), 5, Buf'Unchecked_Access);
+ Entry_Call := Entry_Call.Acceptor_Prev_Call;
+ end loop;
+
+ Write_Buf (Buf'Unchecked_Access);
+ end if;
+
+ Print_Accept_Info (T);
+ end Print_Task_Info;
+
+ ----------------------------
+ -- Print_Task_Info_Header --
+ ----------------------------
+
+ procedure Print_Task_Info_Header is
+ Buf : aliased Buffer;
+
+ begin
+ Clear (Buf'Unchecked_Access);
+ Put ("TASK_ID", Hex_Address_Width, Buf'Unchecked_Access);
+ Put (':', Buf'Unchecked_Access);
+ Put ('F', Buf'Unchecked_Access);
+ Put (':', Buf'Unchecked_Access);
+ Put ("SERIAL_NUMBER", 4, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ Put (" NAME", 15, Buf'Unchecked_Access);
+ Put (" STATE", 10, Buf'Unchecked_Access);
+ Space (11, Buf'Unchecked_Access);
+ Put ("MAST", 5, Buf'Unchecked_Access);
+ Put ("AWAK", 5, Buf'Unchecked_Access);
+ Put ("ATC", 5, Buf'Unchecked_Access);
+ Put ("WT", 3, Buf'Unchecked_Access);
+ Put ("DBG", 3, Buf'Unchecked_Access);
+ Write_Buf (Buf'Unchecked_Access);
+ end Print_Task_Info_Header;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (T : ST.Task_ID;
+ Width : Integer;
+ Buffer : Buffer_Ptr)
+ is
+ J : Integer;
+ X : Integer_Address := +T;
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+ First : constant Integer := Next;
+ Wdth : Integer := Width;
+
+ begin
+ if Wdth > Buf'Last - Next then
+ Wdth := Buf'Last - Next;
+ end if;
+
+ J := Next + (Wdth - 1);
+
+ if X = 0 then
+ Buf (J) := '0';
+
+ else
+ while X > 0 loop
+ Buf (J) := Hex_Digits (X rem 16);
+ J := J - 1;
+ X := X / 16;
+
+ -- Check for overflow
+
+ if J < First and then X > 0 then
+ Buf (J + 1) := '*';
+ exit;
+ end if;
+
+ end loop;
+ end if;
+
+ Next := Next + Wdth;
+ end Put;
+
+ procedure Put
+ (N : Integer_Address;
+ Width : Integer;
+ Buffer : Buffer_Ptr)
+ is
+ J : Integer;
+ X : Integer_Address := N;
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+ First : constant Integer := Next;
+ Wdth : Integer := Width;
+
+ begin
+ if Wdth > Buf'Last - Next then
+ Wdth := Buf'Last - Next;
+ end if;
+
+ J := Next + (Wdth - 1);
+
+ if N = 0 then
+ Buf (J) := '0';
+
+ else
+ while X > 0 loop
+ Buf (J) := Hex_Digits (X rem 10);
+ J := J - 1;
+ X := X / 10;
+
+ -- Check for overflow
+
+ if J < First and then X > 0 then
+ Buf (J + 1) := '*';
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Next := Next + Wdth;
+ end Put;
+
+ procedure Put
+ (S : String;
+ Width : Integer;
+ Buffer : Buffer_Ptr)
+ is
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+ Bound : constant Integer := Integer'Min (Next + Width, Buf'Last);
+ J : Integer := Next;
+
+ begin
+ for K in S'Range loop
+
+ -- Check overflow
+
+ if J >= Bound then
+ Buf (J - 1) := '*';
+ exit;
+ end if;
+
+ Buf (J) := S (K);
+ J := J + 1;
+ end loop;
+
+ Next := Bound;
+ end Put;
+
+ procedure Put
+ (C : Character;
+ Buffer : Buffer_Ptr)
+ is
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+
+ begin
+ if Next >= Buf'Last then
+ Buf (Next) := '*';
+ else Buf (Next) := C;
+ Next := Next + 1;
+ end if;
+ end Put;
+
+ ----------------------
+ -- Resume_All_Tasks --
+ ----------------------
+
+ procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
+ C : ST.Task_ID;
+ R : Boolean;
+
+ begin
+ C := All_Tasks_List;
+
+ while C /= null loop
+ R := STPO.Resume_Task (C, Thread_Self);
+ C := C.Common.All_Tasks_Link;
+ end loop;
+ end Resume_All_Tasks;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID is
+ begin
+ return STPO.Self;
+ end Self;
+
+ ---------------
+ -- 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 : Integer) is
+ begin
+ STPO.Self.User_State := Value;
+ end Set_User_State;
+
+ -----------
+ -- Space --
+ -----------
+
+ procedure Space (Buffer : Buffer_Ptr) is
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+
+ begin
+ if Next >= Buf'Last then
+ Buf (Next) := '*';
+ else
+ Next := Next + 1;
+ end if;
+ end Space;
+
+ procedure Space
+ (N : Integer;
+ Buffer : Buffer_Ptr)
+ is
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+
+ begin
+ if Next + N > Buf'Last then
+ Buf (Next) := '*';
+ else
+ Next := Next + N;
+ end if;
+ end Space;
+
+ -----------------------
+ -- Suspend_All_Tasks --
+ -----------------------
+
+ procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
+ C : ST.Task_ID;
+ R : Boolean;
+
+ begin
+ C := All_Tasks_List;
+
+ while C /= null loop
+ R := STPO.Suspend_Task (C, Thread_Self);
+ C := C.Common.All_Tasks_Link;
+ end loop;
+ 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 : ST.Task_ID;
+ Msg : String;
+ Other_ID : ST.Task_ID;
+ Flag : Character)
+ is
+ Buf : aliased Buffer;
+ use type System.Task_Info.Task_Image_Type;
+
+ begin
+ if Trace_On (Flag) then
+ Clear (Buf'Unchecked_Access);
+ Put (Self_ID, Hex_Address_Width, Buf'Unchecked_Access);
+ Put (':', Buf'Unchecked_Access);
+ Put (Flag, Buf'Unchecked_Access);
+ Put (':', Buf'Unchecked_Access);
+ Put
+ (Integer_Address (Self_ID.Serial_Number),
+ 4, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+
+ if Self_ID.Common.Task_Image = null then
+ Put ("", 15, Buf'Unchecked_Access);
+ else
+ Put (Self_ID.Common.Task_Image.all, 15, Buf'Unchecked_Access);
+ end if;
+
+ Space (Buf'Unchecked_Access);
+
+ if Other_ID /= null then
+ Put
+ (Integer_Address (Other_ID.Serial_Number),
+ 4, Buf'Unchecked_Access);
+ Space (Buf'Unchecked_Access);
+ end if;
+
+ Put (Msg, Buf.Chars'Last - Buf.Next + 1, Buf'Unchecked_Access);
+ Write_Buf (Buf'Unchecked_Access);
+ end if;
+ end Trace;
+
+ procedure Trace
+ (Self_ID : ST.Task_ID;
+ Msg : String;
+ Flag : Character)
+ is
+ begin
+ Trace (Self_ID, Msg, null, Flag);
+ end Trace;
+
+ procedure Trace
+ (Msg : String;
+ Flag : Character)
+ is
+ Self_ID : constant ST.Task_ID := STPO.Self;
+
+ begin
+ Trace (Self_ID, Msg, null, Flag);
+ end Trace;
+
+ procedure Trace
+ (Msg : String;
+ Other_ID : ST.Task_ID;
+ Flag : Character)
+ is
+ Self_ID : constant ST.Task_ID := STPO.Self;
+
+ begin
+ Trace (Self_ID, Msg, null, Flag);
+ end Trace;
+
+ ---------------
+ -- Write_Buf --
+ ---------------
+
+ procedure Write_Buf (Buffer : Buffer_Ptr) is
+ Next : Buf_Range renames Buffer.Next;
+ Buf : Buf_Array renames Buffer.Chars;
+
+ procedure put_char (C : Integer);
+ pragma Import (C, put_char, "put_char");
+
+ begin
+ for J in 1 .. Next - 1 loop
+ put_char (Character'Pos (Buf (J)));
+ end loop;
+
+ put_char (Character'Pos (ASCII.LF));
+ end Write_Buf;
+
+end System.Tasking.Debug;
diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads
new file mode 100644
index 00000000000..b07ab445034
--- /dev/null
+++ b/gcc/ada/s-tasdeb.ads
@@ -0,0 +1,179 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.16 $
+-- --
+-- Copyright (C) 1997-1998, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package encapsulates all direct interfaces to task debugging services
+-- that are needed by gdb with gnat mode (1.17 and higher)
+
+with Interfaces.C;
+with System.Tasking;
+with System.OS_Interface;
+
+package System.Tasking.Debug is
+
+ subtype int is Interfaces.C.int;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+
+ package ST renames System.Tasking;
+
+ Known_Tasks : array (0 .. 999) of Task_ID;
+ -- Global array of tasks read by gdb, and updated by
+ -- Create_Task and Finalize_TCB
+
+ procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id);
+ -- This procedure is used to notify VxGdb of task's creation.
+ -- It must be called by the task's creator.
+
+ procedure Task_Termination_Hook;
+ -- This procedure is used to notify VxGdb of task's termination.
+
+ function Self return Task_ID;
+ -- return system ID of current task
+
+ procedure List_Tasks;
+ -- Print a list of all the known Ada tasks with abbreviated state
+ -- information, one-per-line, to the standard output file
+
+ procedure Print_Current_Task;
+ procedure Print_Task_Info_Header;
+ procedure Print_Task_Info (T : Task_ID);
+ -- Write TASK_ID of current task, in hexadecimal, as one line, to
+ -- the standard output file
+ --
+ -- Beware that Print_Current_Task may print garbage during an early
+ -- stage of activation. There is a small window where a task is just
+ -- initializing itself and has not yet recorded its own task Id.
+ --
+ -- Beware that Print_Current_Task will either not work at all or print
+ -- garbage if it has interrupted a thread of control that does not
+ -- correspond to any Ada task. For example, this is could happen if
+ -- the debugger interrupts a signal handler that is using an alternate
+ -- stack, or interrupts the dispatcher in the underlying thread
+ -- implementation.
+
+ procedure Set_User_State (Value : Integer);
+
+ procedure Print_Accept_Info (T : Task_ID);
+
+ procedure Trace
+ (Self_ID : Task_ID;
+ Msg : String;
+ Other_ID : Task_ID;
+ Flag : Character);
+
+ procedure Trace
+ (Self_ID : Task_ID;
+ Msg : String;
+ Flag : Character);
+
+ procedure Trace
+ (Msg : String;
+ Flag : Character);
+
+ procedure Trace
+ (Msg : String;
+ Other_ID : Task_ID;
+ Flag : Character);
+
+ procedure Set_Trace
+ (Flag : Character;
+ Value : Boolean := True);
+
+ function Image (T : Task_ID) return String;
+
+ 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
+ -- Such functionnality is needed by gdb on some targets (e.g VxWorks)
+ -- Warning: for efficiency purposes, there is no locking.
+
+ 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
+ -- Such functionnality is needed by gdb on some targets (e.g VxWorks)
+ -- Warning: for efficiency purposes, there is no locking.
+
+end System.Tasking.Debug;
+
+-----------------------------
+-- Use of These Functions --
+-----------------------------
+
+-- Calling complicated functions from the debugger is generally pretty
+-- risky, especially in a multithreaded program.
+
+-- The debugger may interrupt something that is not an Ada task,
+-- within the thread implementation, and which is not async-safe.
+
+-- For example, under Solaris, it can interrupt code in "_dynamiclwps",
+-- which seems to serve as dispatcher when all the user threads are
+-- suspended. By experience, we have found that one cannot safely
+-- do certain things, apparently including calls to thread primitives
+-- from the debugger if the debugger has interrupted at one of these
+-- unsafe points. In general, if you interrupt a running program
+-- asynchronously (e.g. via control-C), it will not be safe to
+-- call the subprograms in this package.
+
+-----------------
+-- Future work --
+-----------------
+
+-- It would be nice to be able to tell whether execution has been
+-- interrupted in an Ada task. A heuristic way of checking this would
+-- be if we added to the Ada TCB a component that always contains a
+-- constant value that is unlikely to occur accidentally in code or
+-- data. We could then check this in the debugger-callable subprograms,
+-- and simply return an error code if it looks unsafe to proceed.
+
+-- ???
+-- Recently we have added such a marker as a local variable of the
+-- task-wrapper routine. This allows Self to generate a fake ATCB for
+-- non-Ada threads of control. Given this capability, it is probably
+-- time to revisit the issue above.
+
+-- DEADLOCK
+
+-- We follow a simple rule here to avoid deadlock:
+
+-- We do not use any locks in functions called by gdb, and we do not
+-- traverse linked lists.
+--
+-- The use of an array (Known_Tasks) has many advantages:
+
+-- - Easy and fast to examine;
+-- - No risk of dangling references (to the next element) when traversing
+-- the array.
diff --git a/gcc/ada/s-tasinf.adb b/gcc/ada/s-tasinf.adb
new file mode 100644
index 00000000000..6595f402bb5
--- /dev/null
+++ b/gcc/ada/s-tasinf.adb
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- (Compiler Interface) --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 00000000000..f2bf26ead6f
--- /dev/null
+++ b/gcc/ada/s-tasinf.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 --
+-- (Compiler Interface) --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation of the Task_Info pragma. It is specialized appropriately
+-- for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+with Unchecked_Deallocation;
+package System.Task_Info is
+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 Task_Info_Unspecified 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).
+
+ type Task_Image_Type is access String;
+ -- Used to generate a meaningful identifier for tasks that are variables
+ -- and components of variables.
+
+ procedure Free_Task_Image is new
+ Unchecked_Deallocation (String, Task_Image_Type);
+
+ Unspecified_Task_Info : constant Task_Info_Type := 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 00000000000..08d778f9231
--- /dev/null
+++ b/gcc/ada/s-tasini.adb
@@ -0,0 +1,981 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.63 $
+-- --
+-- Copyright (C) 1991-2001, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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.
+
+-- This package provides overall initialization of the tasking portion
+-- of the RTS. This package must be elaborated before any tasking
+-- features are used. It also contains initialization for
+-- Ada Task Control Block (ATCB) records.
+
+with Ada.Exceptions;
+-- used for Exception_Occurrence_Access.
+
+with System.Tasking;
+pragma Elaborate_All (System.Tasking);
+-- ensure that the first step initializations have been performed
+
+with System.Task_Primitives;
+-- used for Lock
+
+with System.Task_Primitives.Operations;
+-- used for Set_Priority
+-- Write_Lock
+-- Unlock
+-- Initialize_Lock
+
+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.
+
+with System.Tasking.Debug;
+-- used for Trace
+
+with System.Tasking.Task_Attributes;
+-- used for All_Attrs_L
+
+with System.Stack_Checking;
+
+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 System.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.
+
+ function Current_Target_Exception return AE.Exception_Occurrence;
+ pragma Import
+ (Ada, Current_Target_Exception, "__gnat_current_target_exception");
+ -- Import this subprogram from the private part of Ada.Exceptions.
+
+ -----------------------------------------------------------------
+ -- Tasking versions of services needed by non-tasking programs --
+ -----------------------------------------------------------------
+
+ 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_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
+
+ function Get_Exc_Stack_Addr return Address;
+ -- Get the exception stack for the current task
+
+ procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address);
+ -- Self_ID is the Task_ID of the task that gets the exception stack.
+ -- For Self_ID = Null_Address, the current task gets the exception stack.
+
+ function Get_Machine_State_Addr return Address;
+ procedure Set_Machine_State_Addr (Addr : Address);
+ -- Get/Set the address for storing the current task's machine state
+
+ function Get_Current_Excep return SSL.EOA;
+ -- Comments needed???
+
+ procedure Timed_Delay_T (Time : Duration; Mode : Integer);
+ -- Comments needed???
+
+ function Get_Stack_Info return Stack_Checking.Stack_Access;
+ -- Get access to the current task's Stack_Info
+
+ procedure Update_Exception
+ (X : AE.Exception_Occurrence := Current_Target_Exception);
+ -- Handle exception setting and check for pending actions
+
+ ------------------------
+ -- Local Subprograms --
+ ------------------------
+
+ procedure Do_Pending_Action (Self_ID : Task_ID);
+ -- This is introduced to allow more efficient
+ -- in-line expansion of Undefer_Abort.
+
+ ----------------------------
+ -- 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 : 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
+
+ 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 that
+ -- 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
+
+-- pragma Assert
+-- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else
+-- Self_ID.Deferral_Level > 0));
+
+ -- See comment in Defer_Abort on the situations in which it may
+ -- be useful to uncomment the above assertion.
+
+ Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
+ end Defer_Abort_Nestable;
+
+ --------------------
+ -- Defer_Abortion --
+ --------------------
+
+ -- ??????
+ -- Phase out Defer_Abortion without Self_ID
+ -- to reduce overhead due to multiple calls to Self
+
+ procedure Defer_Abortion is
+ Self_ID : constant Task_ID := STPO.Self;
+
+ begin
+ Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
+ end Defer_Abortion;
+
+ -----------------------
+ -- 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 abortion so that we can lock Self_ID.
+
+ Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
+
+ Write_Lock (Self_ID);
+ Self_ID.Pending_Action := False;
+ Poll_Base_Priority_Change (Self_ID);
+ Unlock (Self_ID);
+
+ -- 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.Global_Task_Lock_Nesting = 1);
+ Unlock (Global_Task_Lock'Access);
+ end Final_Task_Unlock;
+
+ --------------
+ -- Init_RTS --
+ --------------
+
+ procedure Init_RTS is
+ Self_Id : Task_ID;
+ begin
+ -- 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;
+
+ Self_Id.Master_Within := Library_Task_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. 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
+
+ -- Initialize lock used to implement mutual exclusion between all tasks
+
+ Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
+
+ -- Initialize lock used to implement mutual exclusion in the package
+ -- System.Task_Attributes.
+
+ Initialize_Lock (System.Tasking.Task_Attributes.All_Attrs_L'Access,
+ All_Attrs_Level);
+
+ -- Notify that the tasking run time has been elaborated so that
+ -- the tasking version of the soft links can be used.
+
+ SSL.Abort_Defer := Defer_Abortion'Access;
+ SSL.Abort_Undefer := Undefer_Abortion'Access;
+ SSL.Update_Exception := Update_Exception'Access;
+ SSL.Lock_Task := Task_Lock'Access;
+ SSL.Unlock_Task := Task_Unlock'Access;
+ 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.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
+ SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access;
+ SSL.Set_Exc_Stack_Addr := Set_Exc_Stack_Addr'Access;
+ SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
+ SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
+ SSL.Get_Current_Excep := Get_Current_Excep'Access;
+ SSL.Timed_Delay := Timed_Delay_T'Access;
+ SSL.Check_Abort_Status := Check_Abort_Status'Access;
+ SSL.Get_Stack_Info := Get_Stack_Info'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_Exc_Stack_Addr (Null_Address, SSL.Get_Exc_Stack_Addr_NT);
+ SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
+ SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+
+ -- Abortion is deferred in a new ATCB, so we need to undefer abortion
+ -- 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 beek 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.Abortion
+ -- for the overall design of the implementation of task abort.
+
+ -- 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 lowl-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 relase 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 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 =>
+ 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 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;
+
+ -------------------------------
+ -- Poll_Base_Priority_Change --
+ -------------------------------
+
+ -- Poll for pending base priority change and for held tasks.
+ -- This should always be called with (only) Self_ID locked.
+ -- It may temporarily release Self_ID's lock.
+
+ -- The call to Yield is to force enqueuing at the
+ -- tail of the dispatching queue.
+
+ -- We must unlock Self_ID for this to take effect,
+ -- since we are inheriting high active priority from the lock.
+
+ -- See also Poll_Base_Priority_Change_At_Entry_Call,
+ -- in package System.Tasking.Entry_Calls.
+
+ -- In this version, we check if the task is held too because
+ -- doing this only in Do_Pending_Action is not enough.
+
+ procedure Poll_Base_Priority_Change (Self_ID : Task_ID) is
+ begin
+ if Dynamic_Priority_Support
+ and then Self_ID.Pending_Priority_Change
+ then
+ -- Check for ceiling violations ???
+
+ Self_ID.Pending_Priority_Change := False;
+
+ if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then
+ Unlock (Self_ID);
+ Yield;
+ Write_Lock (Self_ID);
+
+ elsif Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+
+ else
+ -- Lowering priority
+
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ Unlock (Self_ID);
+ Yield;
+ Write_Lock (Self_ID);
+ end if;
+ end if;
+ end Poll_Base_Priority_Change;
+
+ --------------------------------
+ -- 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 ("Remove_From_All_Tasks_List", 'C'));
+
+ Lock_All_Tasks_List;
+
+ 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;
+
+ Unlock_All_Tasks_List;
+ 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 is
+ T : Task_ID := STPO.Self;
+
+ begin
+ T.Global_Task_Lock_Nesting := T.Global_Task_Lock_Nesting + 1;
+
+ if T.Global_Task_Lock_Nesting = 1 then
+ Defer_Abort_Nestable (T);
+ Write_Lock (Global_Task_Lock'Access);
+ end if;
+ end Task_Lock;
+
+ procedure Task_Lock (Self_ID : Task_ID) is
+ begin
+ Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting + 1;
+
+ if Self_ID.Global_Task_Lock_Nesting = 1 then
+ Defer_Abort_Nestable (Self_ID);
+ Write_Lock (Global_Task_Lock'Access);
+ end if;
+ end Task_Lock;
+
+ -----------------
+ -- Task_Unlock --
+ -----------------
+
+ procedure Task_Unlock is
+ T : Task_ID := STPO.Self;
+
+ begin
+ pragma Assert (T.Global_Task_Lock_Nesting > 0);
+
+ T.Global_Task_Lock_Nesting := T.Global_Task_Lock_Nesting - 1;
+
+ if T.Global_Task_Lock_Nesting = 0 then
+ Unlock (Global_Task_Lock'Access);
+ Undefer_Abort_Nestable (T);
+ end if;
+ end Task_Unlock;
+
+ procedure Task_Unlock (Self_ID : Task_ID) is
+ begin
+ Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting - 1;
+
+ if Self_ID.Global_Task_Lock_Nesting = 0 then
+ Unlock (Global_Task_Lock'Access);
+ Undefer_Abort_Nestable (Self_ID);
+ end if;
+ end Task_Unlock;
+
+ -------------------
+ -- Undefer_Abort --
+ -------------------
+
+ -- Precondition : Self does not hold any locks!
+
+ -- Undefer_Abort is called on any abortion completion point (aka.
+ -- synchronization point). It performs the following actions if they
+ -- are pending: (1) change the base priority, (2) abort the task,
+ -- (3) raise a pending exception.
+
+ -- The priority change has to occur before abortion. Otherwise, it would
+ -- take effect no earlier than the next abortion completion point.
+
+ procedure Undefer_Abort (Self_ID : Task_ID) is
+ begin
+ 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
+ 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;
+
+ ----------------------
+ -- Undefer_Abortion --
+ ----------------------
+
+ -- Phase out RTS-internal use of Undefer_Abortion
+ -- to reduce overhead due to multiple calls to Self.
+
+ procedure Undefer_Abortion is
+ Self_ID : constant Task_ID := STPO.Self;
+
+ begin
+ 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_Abortion;
+
+ ----------------------
+ -- Update_Exception --
+ ----------------------
+
+ -- Call only when holding no locks.
+
+ procedure Update_Exception
+ (X : AE.Exception_Occurrence := 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;
+ Write_Lock (Self_Id);
+ Self_Id.Pending_Action := False;
+ Poll_Base_Priority_Change (Self_Id);
+ Unlock (Self_Id);
+ 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", Caller, 'E'));
+ 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;
+
+ 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 Bodies --
+ ----------------------
+
+ function Get_Current_Excep return SSL.EOA is
+ Me : constant Task_ID := STPO.Self;
+
+ begin
+ return Me.Common.Compiler_Data.Current_Excep'Access;
+ end Get_Current_Excep;
+
+ function Get_Exc_Stack_Addr return Address is
+ Me : constant Task_ID := STPO.Self;
+
+ begin
+ return Me.Common.Compiler_Data.Exc_Stack_Addr;
+ end Get_Exc_Stack_Addr;
+
+ function Get_Jmpbuf_Address return Address is
+ Me : constant Task_ID := STPO.Self;
+
+ begin
+ return Me.Common.Compiler_Data.Jmpbuf_Address;
+ end Get_Jmpbuf_Address;
+
+ function Get_Machine_State_Addr return Address is
+ Me : constant Task_ID := STPO.Self;
+
+ begin
+ return Me.Common.Compiler_Data.Machine_State_Addr;
+ end Get_Machine_State_Addr;
+
+ function Get_Sec_Stack_Addr return Address is
+ Me : constant Task_ID := STPO.Self;
+
+ begin
+ return Me.Common.Compiler_Data.Sec_Stack_Addr;
+ end Get_Sec_Stack_Addr;
+
+ function Get_Stack_Info return Stack_Checking.Stack_Access is
+ Me : constant Task_ID := STPO.Self;
+
+ begin
+ return Me.Common.Compiler_Data.Pri_Stack_Info'Access;
+ end Get_Stack_Info;
+
+ procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address) is
+ Me : Task_ID := To_Task_Id (Self_ID);
+
+ begin
+ if Me = Null_Task then
+ Me := STPO.Self;
+ end if;
+
+ Me.Common.Compiler_Data.Exc_Stack_Addr := Addr;
+ end Set_Exc_Stack_Addr;
+
+ procedure Set_Jmpbuf_Address (Addr : Address) is
+ Me : Task_ID := STPO.Self;
+
+ begin
+ Me.Common.Compiler_Data.Jmpbuf_Address := Addr;
+ end Set_Jmpbuf_Address;
+
+ procedure Set_Machine_State_Addr (Addr : Address) is
+ Me : Task_ID := STPO.Self;
+
+ begin
+ Me.Common.Compiler_Data.Machine_State_Addr := Addr;
+ end Set_Machine_State_Addr;
+
+ procedure Set_Sec_Stack_Addr (Addr : Address) is
+ Me : Task_ID := STPO.Self;
+
+ begin
+ Me.Common.Compiler_Data.Sec_Stack_Addr := Addr;
+ end Set_Sec_Stack_Addr;
+
+ procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
+ Self_ID : constant Task_ID := Self;
+
+ begin
+ STPO.Timed_Delay (Self_ID, Time, Mode);
+ end Timed_Delay_T;
+
+ ------------------------
+ -- 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
+ begin
+ null;
+ end Finalize_Attributes;
+
+ procedure Initialize_Attributes (T : Task_ID) is
+ 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 00000000000..56381c60bcf
--- /dev/null
+++ b/gcc/ada/s-tasini.ads
@@ -0,0 +1,220 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.24 $
+-- --
+-- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides overall initialization of the tasking portion of the
+-- RTS. This package must be elaborated before any tasking features are used.
+-- It also contains initialization for Ada Task Control Block (ATCB) records.
+
+package System.Tasking.Initialization is
+
+ procedure Remove_From_All_Tasks_List (T : Task_ID);
+ -- Remove T from All_Tasks_List.
+
+ ------------------------------------------------
+ -- Static (Compile-Time) Configuration Flags --
+ ------------------------------------------------
+
+ -- ?????
+ -- Maybe this does not belong here? Where else?
+ -- For now, it is here because so is Change_Base_Priority,
+ -- and the two are used together.
+
+ Dynamic_Priority_Support : constant Boolean := True;
+ -- Should we poll for pending base priority changes at every
+ -- abort completion point?
+
+ ---------------------------------
+ -- 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 abortion deferred and T.L write-locked
+
+ Initialize_Attributes_Link : Proc_T := Initialize_Attributes'Access;
+ -- should be called with abortion 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) exceptions that need to be raised
+
+ -- 3) 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 inlinable 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-linable defer/undefer routines,
+ -- for direct call from the compiler. These are not in-lineable
+ -- 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);
+
+ -- NON-INLINE versions without Self_ID for code generated by the
+ -- expander and for hard links
+
+ procedure Defer_Abortion;
+ procedure Undefer_Abortion;
+
+ -- ?????
+ -- Try to phase out all uses of the above versions.
+
+ 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 temporariliy release the lock.
+
+ procedure Poll_Base_Priority_Change (Self_ID : Task_ID);
+ -- Has to be called with Self_ID's ATCB write-locked.
+ -- May temporariliy release the lock.
+ pragma Inline (Poll_Base_Priority_Change);
+
+ ----------------------
+ -- Task Lock/Unlock --
+ ----------------------
+
+ procedure Task_Lock (Self_ID : Task_ID);
+ procedure Task_Unlock (Self_ID : Task_ID);
+ -- 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 o
+ -- 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 00000000000..dcab023fdc5
--- /dev/null
+++ b/gcc/ada/s-taskin.adb
@@ -0,0 +1,181 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K I N G --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.38 $
+-- --
+-- Copyright (C) 1991-2001 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+-- used for Self
+
+with Unchecked_Deallocation;
+-- To recover from failure of ATCB initialization.
+
+with System.Storage_Elements;
+-- Needed for initializing Stack_Info.Size
+
+with System.Parameters;
+-- Used for Adjust_Storage_Size
+
+package body System.Tasking is
+
+ package STPO renames System.Task_Primitives.Operations;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID renames STPO.Self;
+
+ ---------------------
+ -- Initialize_ATCB --
+ ---------------------
+
+ -- Call this only with abort deferred and holding All_Tasks_L.
+
+ 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;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ Stack_Size : System.Parameters.Size_Type;
+ T : in out Task_ID;
+ Success : out Boolean) is
+ begin
+ T.Common.State := Unactivated;
+
+ -- Initialize T.Common.LL
+
+ STPO.Initialize_TCB (T, Success);
+
+ if not Success then
+ Free (T);
+ return;
+ end if;
+
+ T.Common.Parent := Parent;
+ T.Common.Base_Priority := Base_Priority;
+ T.Common.Current_Priority := 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;
+
+ 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;
+
+ Main_Task_Image : aliased String := "main_task";
+ -- Declare a global variable to avoid allocating dynamic memory.
+
+ Main_Priority : Priority;
+ pragma Import (C, Main_Priority, "__gl_main_priority");
+
+ ----------------------------
+ -- Tasking Initialization --
+ ----------------------------
+
+ -- This block 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.
+
+begin
+ declare
+ T : Task_ID;
+ Success : Boolean;
+ Base_Priority : Any_Priority;
+
+ begin
+ -- Initialize Environment Task
+
+ if Main_Priority = Unspecified_Priority then
+ Base_Priority := Default_Priority;
+ else
+ Base_Priority := Main_Priority;
+ end if;
+
+ Success := True;
+ T := STPO.New_ATCB (0);
+ Initialize_ATCB
+ (null, null, Null_Address, Null_Task, null, Base_Priority,
+ 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 := Main_Task_Image'Unrestricted_Access;
+
+ -- 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;
+end System.Tasking;
diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads
new file mode 100644
index 00000000000..de9fe568b98
--- /dev/null
+++ b/gcc/ada/s-taskin.ads
@@ -0,0 +1,983 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K I N G --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.89 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+-- Used for: Exception_Id
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Task_Info;
+-- used for Task_Info_Type, Task_Image_Type
+
+with System.Soft_Links;
+-- used for TSD
+
+with System.Task_Primitives;
+-- used for Private_Data
+-- Lock (in System.Tasking.Protected_Objects)
+
+with Unchecked_Conversion;
+
+package System.Tasking is
+
+ -- -------------------
+ -- -- 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
+ -- number is the number at the left.)
+ --
+ -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock)
+ -- 2. System.Tasking.Initialization.Global_Task_Lock (in body)
+ -- 3. System.Tasking.Task_Attributes.All_Attrs_L
+ -- 4. System.Task_Primitives.Operations.All_Tasks_L
+ -- 5. System.Interrupts.L (in body)
+ -- 6. 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.
+ --
+ -- Sometime 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.
+ --
+ -- For interrupt-handler state, we have a special locking rule.
+ -- See System.Interrupts (spec) for explanation.
+
+ ---------------------------------
+ -- Task_ID related definitions --
+ ---------------------------------
+
+ type Ada_Task_Control_Block;
+
+ type Task_ID is access all Ada_Task_Control_Block;
+
+ 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 Unchecked_Conversion (System.Address, Task_ID);
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ -----------------------
+ -- Enumeration types --
+ -----------------------
+
+ type Task_States is
+ (Unactivated,
+ -- Task has been created but has not been activated.
+ -- It cannot be executing.
+
+ -- 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.
+
+ -- For all states from here down,
+ -- the task has been activated, and may be executing.
+
+ 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 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 the
+ -- completion event.
+ );
+
+ 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;
+
+ ----------------------------------
+ -- 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
+ );
+
+ -- 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 related other definitions --
+ ------------------------------------
+
+ type Activation_Chain is limited private;
+
+ 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;
+
+ ----------------------------------------------
+ -- 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, Call and LL fields.
+
+ ----------------------------------------------------------------------
+ -- Common ATCB section --
+ -- --
+ -- This section is 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.
+
+ 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.
+
+ Task_Image : System.Task_Info.Task_Image_Type;
+ -- holds an access to string that provides a readable id for task,
+ -- built from the variable of which it is a value or component.
+
+ 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. Currently unused; this will
+ -- 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_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: All_Tasks.L.
+
+ 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.
+ 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.
+
+ Environment_Task_Level : constant Master_Level := 1;
+ Independent_Task_Level : constant Master_Level := 2;
+ Library_Task_Level : constant Master_Level := 3;
+
+ ------------------------------
+ -- Task size, 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;
+
+ ------------------------------------
+ -- 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.
+ -- If it has succeeded, State = Cancelled.
+ -- ?????
+ -- Consider merging this into State?
+
+ Requeue_With_Abort : Boolean := False;
+ -- Temporary to tell caller whether requeue is with abort.
+ -- ?????
+ -- Find a better way of doing this.
+
+ 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;
+
+ ----------------------------------------------
+ -- Ada_Task_Control_Block (ATCB) definition --
+ ----------------------------------------------
+
+ type Entry_Call_Array is array (ATC_Level_Index) of
+ aliased Entry_Call_Record;
+
+ D_I_Count : constant := 2;
+ -- This constant may be adjusted, to allow more Address-sized
+ -- attributes to be stored directly in the task control block.
+
+ subtype Direct_Index is Integer range 0 .. D_I_Count - 1;
+ -- Attributes with indices 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_Array is
+ array (Direct_Index) of aliased System.Address;
+
+ type Direct_Index_Vector is mod 2 ** D_I_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.
+
+ New_Base_Priority : System.Any_Priority;
+ -- New value for Base_Priority (for dynamic priorities package).
+ -- Protection: Self.L.
+
+ Global_Task_Lock_Nesting : Natural := 0;
+ -- This is the current nesting level of calls to
+ -- System.Tasking.Stages.Lock_Task_T.
+ -- This allows a task to call Lock_Task_T multiple times without
+ -- deadlocking. A task only locks All_Task_Lock when its
+ -- All_Tasks_Nesting goes from 0 to 1, and only unlocked when it
+ -- goes from 1 to 0.
+ -- Protection: Only accessed by Self.
+
+ 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
+ -- abortion signals from being sent by different aborter while abortion
+ -- 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
+ -- abortion signal when resuming execution. At this point, the abortee
+ -- may have completed abortion to the proper level such that the
+ -- signal (and resulting abortion exception) are not handled any more.
+ -- In other words, the flag prevents a race between multiple aborters
+ -- and the abortee.
+ -- Protection: Self.L.
+
+ 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 abortion
+ -- 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_Abortion has been called by
+ -- this task without a matching Undefer_Abortion 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 : Integer := 0;
+ -- user-writeable location, for use in debugging tasks;
+ -- debugger can display this value to show where the task currently
+ -- is, in user terms
+
+ 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;
+ pragma Volatile (Ada_Task_Control_Block);
+
+ ---------------------
+ -- 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;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ Stack_Size : System.Parameters.Size_Type;
+ T : in out Task_ID;
+ Success : out Boolean);
+ -- Initialize fields of a TCB and link into global TCB structures
+ -- Call this only with abort deferred and holding All_Tasks_L.
+
+private
+
+ Null_Task : constant Task_ID := null;
+
+ type Activation_Chain is record
+ T_ID : Task_ID;
+ end record;
+ pragma Volatile (Activation_Chain);
+
+ -- 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).
+
+end System.Tasking;
diff --git a/gcc/ada/s-tasque.adb b/gcc/ada/s-tasque.adb
new file mode 100644
index 00000000000..19533476073
--- /dev/null
+++ b/gcc/ada/s-tasque.adb
@@ -0,0 +1,632 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.37 $
+-- --
+-- Copyright (C) 1991-2001, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+-- used for Write_Lock
+-- Unlock
+
+with System.Tasking.Initialization;
+-- used for Wakeup_Entry_Caller
+
+package body System.Tasking.Queuing is
+
+ use System.Task_Primitives.Operations;
+ use System.Tasking.Protected_Objects;
+ use System.Tasking.Protected_Objects.Entries;
+
+ procedure Wakeup_Entry_Caller
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link;
+ New_State : Entry_Call_State)
+ renames Initialization.Wakeup_Entry_Caller;
+
+ -- 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)
+ is
+ Entry_Call : Entry_Call_Link;
+
+ begin
+ 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;
+ 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 : in 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 : in 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;
+
+ begin
+ Entry_Call := null;
+
+ begin
+ if Priority_Queuing then
+
+ -- Priority queuing
+
+ 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;
+
+ else
+ -- FIFO queuing
+
+ 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;
+ Temp_Entry : Task_Entry_Index;
+
+ begin
+ Open_Alternative := False;
+ Entry_Call := null;
+
+ if Priority_Queuing then
+
+ -- Priority Queuing
+
+ 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
+
+ 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
+ Selection := No_Rendezvous;
+
+ else
+ 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);
+ 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 00000000000..9ee56095c0e
--- /dev/null
+++ b/gcc/ada/s-tasque.ads
@@ -0,0 +1,102 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.21 $
+-- --
+-- Copyright (C) 1991-1998 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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);
+ -- 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
+ -- Raise_Pending_Exception.
+
+ 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 : in Entry_Queue) return Entry_Call_Link;
+ -- Return the head of entry_queue E
+ pragma Inline (Head);
+
+ 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;
+ -- Return True if Call is on any entry_queue at all
+ pragma Inline (Onqueue);
+
+ function Count_Waiting (E : in 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 inforced, 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 00000000000..516cee0fd2e
--- /dev/null
+++ b/gcc/ada/s-tasren.adb
@@ -0,0 +1,1815 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.101 $
+-- --
+-- Copyright (C) 1991-2001, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+-- Used for Exception_ID
+-- Null_Id
+-- Save_Occurrence
+-- Raise_Exception
+
+with System.Task_Primitives.Operations;
+-- used for Get_Priority
+-- Set_Priority
+-- Write_Lock
+-- Unlock
+-- Sleep
+-- Wakeup
+-- Timed_Sleep
+
+with System.Tasking.Entry_Calls;
+-- Used for Wait_For_Completion
+-- Wait_For_Completion_With_Timeout
+-- Wait_Until_Abortable
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort
+-- Undefer_Abort
+-- Poll_Base_Priority_Change
+
+with System.Tasking.Queuing;
+-- used for Enqueue
+-- Dequeue_Head
+-- Select_Task_Entry_Call
+-- Count_Waiting
+
+with System.Tasking.Utilities;
+-- used for Check_Exception
+-- Make_Passive
+-- Wakeup_Entry_Caller
+
+with System.Tasking.Protected_Objects.Operations;
+-- used for PO_Do_Or_Queue
+-- PO_Service_Entries
+-- Lock_Entries
+-- Unlock_Entries
+
+with System.Tasking.Debug;
+-- used for Trace
+
+package body System.Tasking.Rendezvous is
+
+ package STPO renames System.Task_Primitives.Operations;
+ package POO renames System.Tasking.Protected_Objects.Operations;
+ package POE renames System.Tasking.Protected_Objects.Entries;
+
+ use System.Task_Primitives;
+ use System.Task_Primitives.Operations;
+
+ 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);
+
+ 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.
+
+ 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
+ -- privious caller and adjust the priority. Also we need to make
+ -- this call not Abortable (Cancellable) since the rendezvous has
+ -- already been started.
+
+ function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean;
+ pragma Inline (Is_Entry_Open);
+ -- Call this only with abort deferred and holding lock of T.
+
+ 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 abortion.
+ -- Make sure Self_Id is locked before calling this routine.
+
+ -----------------
+ -- Accept_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;
+ -- <<L26b>>
+ -- 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_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);
+
+ 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);
+ Initialization.Undefer_Abort (Self_Id);
+
+ -- Should never get here ???
+
+ pragma Assert (False);
+ raise Standard'Abort_Signal;
+ end if;
+
+ -- If someone completed this task, this task should not try to
+ -- access its pending entry calls or queues in this case, as they
+ -- are being emptied. Wait for abortion to kill us.
+ -- ?????
+ -- Recheck the correctness of the above, now that we have made
+ -- changes. The logic above seems to be based on the assumption
+ -- that one task can safely clean up another's in-service accepts.
+ -- ?????
+ -- Why do we need to block here in this case?
+ -- Why not just return and let Undefer_Abort do its work?
+
+ 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
+
+ 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.Pending_ATC_Level >= Self_Id.ATC_Nesting_Level then
+ Caller := Self_Id.Common.Call.Self;
+ Uninterpreted_Data :=
+ Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
+ end if;
+
+ -- If this task has been aborted, skip the Uninterpreted_Data load
+ -- (Caller will not be reliable) and fall through to
+ -- Undefer_Abort which will allow the task to be killed.
+ -- ?????
+ -- Perhaps we could do the code anyway, if it has no harm, in order
+ -- to get better performance for the normal case.
+
+ end if;
+
+ -- Self_Id.Common.Call should already be updated by the Caller
+ -- On return, we will start the rendezvous.
+
+ STPO.Unlock (Self_Id);
+ Initialization.Undefer_Abort (Self_Id);
+ end Accept_Call;
+
+ --------------------
+ -- Accept_Trivial --
+ --------------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+ -- This should only be called when there is no accept body,
+ -- or the except 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;
+
+ 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);
+ 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);
+ Initialization.Undefer_Abort_Nestable (Self_Id);
+
+ -- Should never get here ???
+
+ pragma Assert (False);
+ raise Standard'Abort_Signal;
+ end if;
+
+ -- If someone completed this task, this task should not try to
+ -- access its pending entry calls or queues in this case, as they
+ -- are being emptied. Wait for abortion to kill us.
+ -- ?????
+ -- Recheck the correctness of the above, now that we have made
+ -- changes.
+
+ 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;
+
+ 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;
+
+ Initialization.Undefer_Abort_Nestable (Self_Id);
+ end Accept_Trivial;
+
+ --------------------
+ -- Boost_Priority --
+ --------------------
+
+ -- Call this only with abort deferred and holding lock of Acceptor.
+
+ procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is
+ Caller : Task_ID := Call.Self;
+ Caller_Prio : System.Any_Priority := Get_Priority (Caller);
+ Acceptor_Prio : 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 --
+ -----------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+
+ procedure Call_Simple
+ (Acceptor : Task_ID;
+ E : Task_Entry_Index;
+ Uninterpreted_Data : System.Address)
+ is
+ Rendezvous_Successful : Boolean;
+ begin
+ Call_Synchronous
+ (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
+ end Call_Simple;
+
+ ----------------------
+ -- Call_Synchronous --
+ ----------------------
+
+ -- Compiler interface.
+ -- Also called from inside Call_Simple and Task_Entry_Call.
+
+ 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 this is a call made inside of an abort deferred region,
+ -- the call should be never abortable.
+
+ if Self_Id.Deferral_Level > 1 then
+ Entry_Call.State := Never_Abortable;
+ else
+ Entry_Call.State := Now_Abortable;
+ end if;
+
+ 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;
+
+ -- Note: the caller will undefer abortion on return (see WARNING above)
+
+ if not Task_Do_Or_Queue
+ (Self_Id, Entry_Call, With_Abort => True)
+ then
+ Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
+ Initialization.Undefer_Abort (Self_Id);
+ pragma Debug
+ (Debug.Trace (Self_Id, "CS: exited to ATC level: " &
+ ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
+ 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 (Self_Id, Entry_Call);
+ pragma Debug
+ (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
+ Rendezvous_Successful := Entry_Call.State = Done;
+ STPO.Unlock (Self_Id);
+ Local_Undefer_Abort (Self_Id);
+ Entry_Calls.Check_Exception (Self_Id, Entry_Call);
+ end Call_Synchronous;
+
+ --------------
+ -- Callable --
+ --------------
+
+ -- Compiler interface.
+ -- Do not call from within the RTS,
+ -- except for body of Ada.Task_Identification.
+
+ function Callable (T : Task_ID) return Boolean is
+ Result : Boolean;
+ Self_Id : constant Task_ID := STPO.Self;
+
+ begin
+ Initialization.Defer_Abort (Self_Id);
+ STPO.Write_Lock (T);
+ Result := T.Callable;
+ STPO.Unlock (T);
+ Initialization.Undefer_Abort (Self_Id);
+ return Result;
+ end Callable;
+
+ ----------------------------
+ -- Cancel_Task_Entry_Call --
+ ----------------------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+ -- Call only with abort deferred.
+
+ 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 --
+ -------------------------
+
+ -- See comments for Exceptional_Complete_Rendezvous.
+
+ procedure Complete_Rendezvous is
+ begin
+ Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);
+ end Complete_Rendezvous;
+
+ -------------------------------------
+ -- Exceptional_Complete_Rendezvous --
+ -------------------------------------
+
+ -- Compiler interface.
+ -- Also called from Complete_Rendezvous.
+ -- ?????
+ -- 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.
+ -- ?????
+ -- If we don't change the interface, consider instead
+ -- 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.
+
+ 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;
+
+ 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");
+
+ use type STPE.Protection_Entries_Access;
+
+ begin
+ 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.
+ 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
+ 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;
+
+ 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 not Task_Do_Or_Queue
+ (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
+ then
+ Initialization.Undefer_Abort (Self_Id);
+ raise Tasking_Error;
+ 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;
+ STPO.Write_Lock (Caller);
+ Initialization.Wakeup_Entry_Caller
+ (Self_Id, Entry_Call, Done);
+ STPO.Unlock (Caller);
+
+ else
+ POO.PO_Do_Or_Queue
+ (Self_Id, Called_PO, Entry_Call,
+ Entry_Call.Requeue_With_Abort);
+ POO.PO_Service_Entries (Self_Id, Called_PO);
+ STPE.Unlock_Entries (Called_PO);
+ end if;
+ end if;
+
+ Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority,
+ Self_Id);
+
+ else
+ -- The call does not need to be requeued.
+
+ Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
+ Entry_Call.Exception_To_Raise := Ex;
+ STPO.Write_Lock (Caller);
+
+ -- Done with Caller locked to make sure that Wakeup is not lost.
+
+ if Ex /= Ada.Exceptions.Null_Id then
+ Ada.Exceptions.Save_Occurrence
+ (Caller.Common.Compiler_Data.Current_Excep,
+ Self_Id.Common.Compiler_Data.Current_Excep);
+ end if;
+
+ Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ STPO.Unlock (Caller);
+ Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority,
+ Self_Id);
+ 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;
+
+ -------------------
+ -- Is_Entry_Open --
+ -------------------
+
+ -- Call this only with abort deferred and holding lock of T.
+
+ function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean is
+ begin
+ pragma Assert (T.Open_Accepts /= null);
+
+ if T.Open_Accepts /= null then
+ for J in T.Open_Accepts'Range loop
+
+ pragma Assert (J > 0);
+
+ if E = T.Open_Accepts (J).S then
+ return True;
+ end if;
+ end loop;
+ end if;
+
+ return False;
+ end Is_Entry_Open;
+
+ -------------------------------------
+ -- Requeue_Protected_To_Task_Entry --
+ -------------------------------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+
+ -- entry e2 when b is
+ -- begin
+ -- b := false;
+ -- ...A...
+ -- requeue t.e2;
+ -- end e2;
+
+ -- 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 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.Requeue_With_Abort := With_Abort;
+ Object.Call_In_Progress := null;
+ end Requeue_Protected_To_Task_Entry;
+
+ ------------------------
+ -- Requeue_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_Rendezous, 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.
+
+ -- accept e1 do
+ -- ...A...
+ -- requeue e2;
+ -- ...B...
+ -- end e1;
+
+ -- A62b : address;
+ -- L61b : label
+ -- begin
+ -- accept_call (1, A62b);
+ -- ...A...
+ -- requeue_task_entry (tTV!(t)._task_id, 2, false);
+ -- goto L61b;
+ -- ...B...
+ -- complete_rendezvous;
+ -- <<L61b>>
+ -- exception
+ -- when others =>
+ -- exceptional_complete_rendezvous (current_exception);
+ -- end;
+
+ 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.Requeue_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 --
+ --------------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+ -- See comments on Accept_Call.
+
+ -- source code:
+
+ -- select accept e1 do
+ -- ...A...
+ -- end e1;
+ -- ...B...
+ -- or accept e2;
+ -- ...C...
+ -- end select;
+
+ -- expansion:
+
+ -- A32b : address;
+ -- declare
+ -- null;
+ -- if accept_alternative'size * 2 >= 16#8000_0000# then
+ -- raise storage_error;
+ -- end if;
+ -- A37b : T36b;
+ -- A37b (1) := (null_body => false, s => 1);
+ -- A37b (2) := (null_body => true, s => 2);
+ -- if accept_alternative'size * 2 >= 16#8000_0000# then
+ -- raise storage_error;
+ -- end if;
+ -- S0 : aliased T36b := accept_list'A37b;
+ -- J1 : select_index := 0;
+ -- L3 : label
+ -- L1 : label
+ -- L2 : label
+ -- procedure e1A is
+ -- begin
+ -- abort_undefer.all;
+ -- L31b : label
+ -- ...A...
+ -- <<L31b>>
+ -- 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;
+ -- <<L1>>
+ -- ...B...
+ -- goto L3;
+ -- <<L2>>
+ -- ...C...
+ -- goto L3;
+ -- <<L3>>
+ -- end;
+
+ 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);
+ 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);
+
+ -- ??? In some cases abort is deferred more than once. Need to figure
+ -- out why.
+
+ Self_Id.Deferral_Level := 1;
+
+ Initialization.Undefer_Abort (Self_Id);
+
+ -- Should never get here ???
+
+ pragma Assert (False);
+ raise Standard'Abort_Signal;
+ end if;
+
+ -- If someone completed this task, this task should not try to
+ -- access its pending entry calls or queues in this case, as they
+ -- are being emptied. Wait for abortion to kill us.
+ -- ?????
+ -- Recheck the correctness of the above, now that we have made
+ -- changes.
+
+ 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;
+
+ -- ??????
+ -- Recheck the logic above against the ARM.
+
+ -- 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 abortion
+ -- 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.
+
+ 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'));
+ 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 abortion.
+ -- 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);
+
+ 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);
+
+ STPO.Unlock (Self_Id);
+
+ when Terminate_Selected =>
+
+ -- Terminate alternative is open
+
+ Self_Id.Open_Accepts := Open_Accepts;
+ Self_Id.Common.State := Acceptor_Sleep;
+ STPO.Unlock (Self_Id);
+
+ -- ?????
+ -- We need to check if a signal is pending on an open interrupt
+ -- entry. Otherwise this task would become potentially terminatable
+ -- and, if none of the siblings are active
+ -- any more, the task could not wake up any more, even though a
+ -- signal might be pending on an open interrupt entry.
+ -- -------------
+ -- This comment paragraph does not make sense. Is it obsolete?
+ -- There was no code here to check for pending signals.
+
+ -- Notify ancestors that this task is on a terminate alternative.
+
+ Utilities.Make_Passive (Self_Id, Task_Completed => False);
+
+ -- Wait for normal entry call or termination
+
+ pragma Assert (Self_Id.ATC_Nesting_Level = 1);
+
+ STPO.Write_Lock (Self_Id);
+
+ loop
+ Initialization.Poll_Base_Priority_Change (Self_Id);
+ exit when Self_Id.Open_Accepts = null;
+ Sleep (Self_Id, Acceptor_Sleep);
+ end loop;
+
+ Self_Id.Common.State := Runnable;
+
+ 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);
+
+ -- Trust that it is OK to fall through.
+
+ null;
+
+ 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
+ Initialization.Poll_Base_Priority_Change (Self_Id);
+ 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);
+ Initialization.Undefer_Abort (Self_Id);
+ Ada.Exceptions.Raise_Exception (Program_Error'Identity,
+ "Entry call not a delay mode");
+ end if;
+
+ end case;
+
+ -- 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 --
+ ------------------------------------
+
+ -- Call this only with abort deferred and holding lock of Acceptor.
+
+ 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 --
+ ----------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+
+ 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);
+ STPO.Write_Lock (Self_Id);
+ Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
+ STPO.Unlock (Self_Id);
+ Initialization.Undefer_Abort (Self_Id);
+ return Return_Count;
+ end Task_Count;
+
+ ----------------------
+ -- Task_Do_Or_Queue --
+ ----------------------
+
+ -- Call this only with abort deferred and holding no locks.
+ -- May propagate an exception, including Abort_Signal & Tasking_Error.
+ -- ?????
+ -- See Check_Callable. Check all call contexts to verify
+ -- it is OK to raise an exception.
+
+ -- Find out whether Entry_Call can be accepted immediately.
+ -- If the Acceptor is not callable, raise Tasking_Error.
+ -- 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.
+
+ function Task_Do_Or_Queue
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link;
+ With_Abort : Boolean) 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
+ 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.
+ -- ?????
+ -- Is there some better solution?
+
+ 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 raise Tasking_Error. The call is not aborted
+ -- for an asynchronous call, since Cancel_Task_Entry_Call
+ -- will do the cancelation in that case.
+ -- ????? .....
+ -- Does the above still make sense?
+
+ if not Acceptor.Callable then
+ STPO.Unlock (Acceptor);
+
+ if Parent_Locked then
+ STPO.Unlock (Acceptor.Common.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 Entry_Call.Mode /= Conditional_Call
+ or else not With_Abort
+ then
+ -- 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 (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
+
+ -- Asynchronous_Call or Conditional_Call
+
+ Entry_Call.Self /= Self_ID
+
+ 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;
+
+ else
+ -- Conditional_Call and With_Abort
+
+ 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);
+ 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 Mode = Simple_Call or else Mode = Conditional_Call then
+ Call_Synchronous
+ (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
+
+ else
+ -- This is an asynchronous call
+
+ -- Abortion must already be deferred by the compiler-generated
+ -- code. Without this, an abortion 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;
+
+ if not Task_Do_Or_Queue
+ (Self_Id, Entry_Call, With_Abort => True)
+ then
+ Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
+ pragma Debug
+ (Debug.Trace (Self_Id, "TEC: exited to ATC level: " &
+ ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
+ Initialization.Undefer_Abort (Self_Id);
+ 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;
+
+ -- Note: following assignment needs to be atomic.
+
+ Rendezvous_Successful := Entry_Call.State = Done;
+ end if;
+ end Task_Entry_Call;
+
+ -----------------------
+ -- Task_Entry_Caller --
+ -----------------------
+
+ -- Compiler interface only.
+
+ 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 --
+ --------------------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+
+ 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 := False;
+ begin
+ pragma Assert (Select_Mode = Delay_Mode);
+
+ Initialization.Defer_Abort (Self_Id);
+
+ -- If we are aborted here, the effect will be pending
+
+ 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);
+ Initialization.Undefer_Abort (Self_Id);
+
+ -- Should never get here ???
+
+ pragma Assert (False);
+ raise Standard'Abort_Signal;
+ end if;
+
+ -- If someone completed this task, this task should not try to
+ -- access its pending entry calls or queues in this case, as they
+ -- are being emptied. Wait for abortion to kill us.
+ -- ?????
+ -- Recheck the correctness of the above, now that we have made
+ -- changes.
+
+ 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 abortion
+ -- 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
+
+ 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_Sleep;
+
+ loop
+ Initialization.Poll_Base_Priority_Change (Self_Id);
+ exit when Self_Id.Open_Accepts = null;
+
+ if Timedout then
+ Sleep (Self_Id, Acceptor_Sleep);
+ else
+ STPO.Timed_Sleep (Self_Id, Timeout, Mode,
+ Acceptor_Sleep, Timedout, Yielded);
+ end if;
+
+ if Timedout then
+ Self_Id.Open_Accepts := null;
+ 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 abortion.
+ -- 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);
+ if not Yielded then
+ Yield;
+ end if;
+
+ 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
+ -- (Abortion, Priority change)
+ -- 3) Spurious wakeup
+
+ Self_Id.Open_Accepts := null;
+ Self_Id.Common.State := Acceptor_Sleep;
+
+ Initialization.Poll_Base_Priority_Change (Self_Id);
+
+ STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
+ Timedout, Yielded);
+
+ Self_Id.Common.State := Runnable;
+
+ STPO.Unlock (Self_Id);
+
+ if not Yielded then
+ Yield;
+ end if;
+
+ when others =>
+ -- Should never get here ???
+
+ pragma Assert (False);
+ null;
+ end case;
+
+ -- 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 --
+ ---------------------------
+
+ -- Compiler interface only. Do not call from within the RTS.
+
+ 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;
+
+ begin
+ 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'));
+
+ 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.
+
+ if Self_Id.Deferral_Level > 1 then
+ Entry_Call.State := Never_Abortable;
+ else
+ Entry_Call.State := Now_Abortable;
+ end if;
+
+ 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;
+
+ -- Note: the caller will undefer abortion on return (see WARNING above)
+
+ if not Task_Do_Or_Queue
+ (Self_Id, Entry_Call, With_Abort => True)
+ then
+ Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
+
+ pragma Debug
+ (Debug.Trace (Self_Id, "TTEC: exited to ATC level: " &
+ ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
+
+ Initialization.Undefer_Abort (Self_Id);
+ raise Tasking_Error;
+ end if;
+
+ Entry_Calls.Wait_For_Completion_With_Timeout
+ (Self_Id, Entry_Call, Timeout, Mode);
+ 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 --
+ -------------------
+
+ -- Call this only with abort deferred and holding lock of Self_Id.
+ -- Wait for normal call and a pending action.
+
+ procedure Wait_For_Call (Self_Id : Task_ID) is
+ begin
+ Self_Id.Common.State := Acceptor_Sleep;
+
+ loop
+ Initialization.Poll_Base_Priority_Change (Self_Id);
+
+ 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 00000000000..97c21428b58
--- /dev/null
+++ b/gcc/ada/s-tasren.ads
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.26 $ --
+-- --
+-- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+with Ada.Exceptions;
+-- Used for, Exception_Id
+
+with System.Tasking.Protected_Objects.Entries;
+-- used for Protection_Entries
+
+package System.Tasking.Rendezvous is
+ -- This interface is described in the document
+ -- Gnu Ada Runtime Library Interface (GNARLI).
+
+ 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
+
+ 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.
+
+ procedure Call_Simple
+ (Acceptor : Task_ID;
+ E : Task_Entry_Index;
+ Uninterpreted_Data : System.Address);
+ -- Simple entry call
+
+ procedure Cancel_Task_Entry_Call (Cancelled : out Boolean);
+ -- Cancel pending task entry call
+
+ procedure Requeue_Task_Entry
+ (Acceptor : Task_ID;
+ E : Task_Entry_Index;
+ With_Abort : Boolean);
+
+ procedure Requeue_Protected_To_Task_Entry
+ (Object : STPE.Protection_Entries_Access;
+ Acceptor : Task_ID;
+ E : Task_Entry_Index;
+ With_Abort : Boolean);
+
+ procedure Selective_Wait
+ (Open_Accepts : Accept_List_Access;
+ Select_Mode : Select_Modes;
+ Uninterpreted_Data : out System.Address;
+ Index : out Select_Index);
+ -- 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);
+ -- Selective wait with timeout without using ATC.
+
+ procedure Accept_Call
+ (E : Task_Entry_Index;
+ Uninterpreted_Data : out System.Address);
+ -- Accept an entry call
+
+ procedure Accept_Trivial (E : Task_Entry_Index);
+ -- Accept an entry call that has no parameters and no body
+
+ function Task_Count (E : Task_Entry_Index) return Natural;
+ -- Return number of tasks waiting on the entry E (of current task)
+
+ function Callable (T : Task_ID) return Boolean;
+ -- Return T'CALLABLE
+
+ 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)).
+
+ 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;
+ With_Abort : Boolean) return Boolean;
+ -- Call this only with abort deferred and holding lock of Acceptor.
+ -- 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 00000000000..52af39eeed1
--- /dev/null
+++ b/gcc/ada/s-tasres.ads
@@ -0,0 +1,40 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.1 $
+-- --
+-- Copyright (C) 1998-1999, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 00000000000..3c265f2f1d2
--- /dev/null
+++ b/gcc/ada/s-tassta.adb
@@ -0,0 +1,1549 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.138 $
+-- --
+-- Copyright (C) 1991-2001 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+-- used for Raise_Exception
+
+with System.Tasking.Debug;
+pragma Warnings (Off, System.Tasking.Debug);
+-- used for enabling tasking facilities with gdb
+
+with System.Address_Image;
+-- used for the function itself.
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Task_Info;
+-- used for Task_Info_Type
+-- Task_Image_Type
+
+with System.Task_Primitives.Operations;
+-- used for Finalize_Lock
+-- Enter_Task
+-- Write_Lock
+-- Unlock
+-- Sleep
+-- Wakeup
+-- Get_Priority
+-- Lock/Unlock_All_Tasks_List
+-- New_ATCB
+
+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 presense of tasking, they must be
+-- replaced with pointers to task-specific versions.
+-- Also used for Create_TSD, Destroy_TSD, Get_Current_Excep
+
+with System.Tasking.Initialization;
+-- Used for Remove_From_All_Tasks_List
+-- Defer_Abort
+-- Undefer_Abort
+-- Initialization.Poll_Base_Priority_Change
+-- Finalize_Attributes_Link
+-- Initialize_Attributes_Link
+
+pragma Elaborate_All (System.Tasking.Initialization);
+-- This insures that tasking is initialized if any tasks are created.
+
+with System.Tasking.Utilities;
+-- Used for Make_Passive
+-- Abort_One_Task
+
+with System.Tasking.Queuing;
+-- Used for Dequeue_Head
+
+with System.Tasking.Rendezvous;
+-- Used for Call_Simple
+
+with System.OS_Primitives;
+-- Used for Delay_Modes
+
+with System.Finalization_Implementation;
+-- Used for System.Finalization_Implementation.Finalize_Global_List
+
+with Interfaces.C;
+-- Used for type Unsigned.
+
+with System.Secondary_Stack;
+-- used for SS_Init;
+
+with System.Storage_Elements;
+-- used for Storage_Array;
+
+with System.Standard_Library;
+-- used for Exception_Trace
+
+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 System.Task_Primitives;
+ use System.Task_Primitives.Operations;
+ use System.Task_Info;
+
+ procedure Wakeup_Entry_Caller
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link;
+ New_State : Entry_Call_State)
+ renames Initialization.Wakeup_Entry_Caller;
+
+ procedure Cancel_Queued_Entry_Calls (T : Task_ID)
+ renames Utilities.Cancel_Queued_Entry_Calls;
+
+ procedure Abort_One_Task
+ (Self_ID : Task_ID;
+ T : Task_ID)
+ renames Utilities.Abort_One_Task;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Notify_Exception
+ (Self_Id : Task_ID;
+ Excep : Exception_Occurrence);
+ -- This procedure will output the task ID and the exception information,
+ -- including traceback if available.
+
+ 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 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
+ -- Finalizate_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.
+ --
+ -- Does not defer abortion (unlike Complete_Activation).
+
+ procedure Abort_Dependents (Self_ID : Task_ID);
+ -- Abort all the dependents of Self at our current master
+ -- nesting level.
+
+ 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.
+ --
+ -- It is also called from Unchecked_Deallocation, for objects that
+ -- are or contain tasks.
+ --
+ -- Different code is used at master completion, in Terminate_Dependents,
+ -- due to a need for tighter synchronization with the master.
+
+ procedure Terminate_Task (Self_ID : Task_ID);
+ -- Terminate the calling task.
+ -- This should only be called by the Task_Wrapper procedure.
+
+ ----------------------
+ -- Abort_Dependents --
+ ----------------------
+
+ -- Abort all the direct dependents of Self at its current master
+ -- nesting level, plus all of their dependents, transitively.
+ -- No locks should be held when this routine is called.
+
+ procedure Abort_Dependents (Self_ID : Task_ID) is
+ C : Task_ID;
+ P : Task_ID;
+
+ begin
+ Lock_All_Tasks_List;
+
+ 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 take worry about them. Need to
+ -- double check this.
+
+ if C.Master_of_Task = Self_ID.Master_Within then
+ 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;
+ Unlock_All_Tasks_List;
+ 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
+ pragma Debug
+ (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
+
+ Initialization.Defer_Abort_Nestable (Self_ID);
+
+ pragma Assert (Self_ID.Common.Wait_Count = 0);
+
+ -- Lock All_Tasks_L, to prevent activated tasks
+ -- from racing ahead before we finish activating the chain.
+
+ -- ?????
+ -- Is there some less heavy-handed way?
+ -- In an earlier version, we used the activator's lock here,
+ -- but that violated the locking order rule when we had
+ -- to lock the parent later.
+
+ Lock_All_Tasks_List;
+
+ -- 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_All_Tasks_List;
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+ Raise_Exception
+ (Program_Error'Identity, "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);
+
+ if C.Common.Base_Priority < Get_Priority (Self_ID) then
+ Activate_Prio := Get_Priority (Self_ID);
+ else
+ Activate_Prio := C.Common.Base_Priority;
+ end if;
+
+ 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_All_Tasks_List pair
+ -- in the task wrapper, to prevent it from racing ahead.
+
+ if Success then
+ C.Common.State := Runnable;
+ 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;
+
+ 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;
+
+ Unlock_All_Tasks_List;
+
+ -- 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;
+ 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
+ Initialization.Poll_Base_Priority_Change (Self_ID);
+ exit when Self_ID.Common.Wait_Count = 0;
+ Sleep (Self_ID, Activator_Sleep);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ Unlock (Self_ID);
+
+ -- 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_Exception (Tasking_Error'Identity,
+ "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);
+ Vulnerable_Complete_Activation (Self_ID);
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+
+ -- ?????
+ -- Why do we need to allow for nested deferral here?
+
+ end Complete_Activation;
+
+ ---------------------
+ -- Complete_Master --
+ ---------------------
+
+ procedure Complete_Master is
+ Self_ID : Task_ID := STPO.Self;
+
+ begin
+ pragma Assert (Self_ID.Deferral_Level > 0);
+
+ 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);
+
+ 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;
+ 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 : System.Task_Info.Task_Image_Type;
+ Created_Task : out Task_ID)
+ is
+ T, P : Task_ID;
+ Self_ID : constant Task_ID := STPO.Self;
+ Success : Boolean;
+ Base_Priority : System.Any_Priority;
+
+ begin
+ pragma Debug
+ (Debug.Trace (Self_ID, "Create_Task", 'C'));
+
+ if Priority = Unspecified_Priority then
+ Base_Priority := Self_ID.Common.Base_Priority;
+ else
+ Base_Priority := System.Any_Priority (Priority);
+ 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_Exception (Storage_Error'Identity, "Cannot allocate task");
+ end;
+
+ -- All_Tasks_L 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_All_Tasks_List;
+ 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_All_Tasks_List;
+ 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, Task_Info, Size, T, Success);
+
+ if not Success then
+ Unlock (Self_ID);
+ Unlock_All_Tasks_List;
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+ Raise_Exception
+ (Storage_Error'Identity, "Failed to initialize task");
+ end if;
+
+ T.Master_of_Task := Master;
+ 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;
+
+ T.Common.Task_Image := Task_Image;
+ Unlock (Self_ID);
+ Unlock_All_Tasks_List;
+
+ -- 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);
+ end Create_Task;
+
+ --------------------
+ -- Current_Master --
+ --------------------
+
+ function Current_Master return Master_Level is
+ Self_ID : constant Task_ID := STPO.Self;
+
+ begin
+ return Self_ID.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
+ 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);
+ 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;
+ Zero_Independent : Boolean;
+
+ 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 (cf 5619-003).
+
+ 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.
+
+ Abort_Dependents (Self_ID);
+
+ -- We need to explicitely wait for the task to be
+ -- terminated here because on true concurrent system, we
+ -- may end this procedure before the tasks are really
+ -- terminated.
+
+ loop
+ Write_Lock (Self_ID);
+ Zero_Independent := Utilities.Independent_Task_Count = 0;
+ Unlock (Self_ID);
+
+ -- We used to yield here, but this did not take into account
+ -- low priority tasks that would cause dead lock in some cases.
+ -- See 8126-020.
+
+ Timed_Delay (Self_ID, 0.01, System.OS_Primitives.Relative);
+ exit when Zero_Independent;
+ end loop;
+
+ -- ??? On multi-processor environments, it seems that the above loop
+ -- isn't sufficient, so we need to add an additional delay.
+
+ Timed_Delay (Self_ID, 0.1, System.OS_Primitives.Relative);
+
+ -- Complete the environment task.
+
+ Vulnerable_Complete_Task (Self_ID);
+
+ System.Finalization_Implementation.Finalize_Global_List;
+
+ 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.Get_Exc_Stack_Addr := SSL.Get_Exc_Stack_Addr_NT'Access;
+ SSL.Set_Exc_Stack_Addr := SSL.Set_Exc_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.All_Tasks_L.
+ end Finalize_Global_Tasks;
+
+ ---------------
+ -- 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);
+
+ if T.Common.Task_Image /= null then
+ Free_Task_Image (T.Common.Task_Image);
+ end if;
+
+ Initialization.Remove_From_All_Tasks_List (T);
+ Initialization.Task_Unlock (Self_Id);
+
+ 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;
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ procedure Notify_Exception
+ (Self_Id : Task_ID;
+ Excep : Exception_Occurrence)
+ is
+ procedure To_Stderr (S : String);
+ pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
+
+ use System.Task_Info;
+ use System.Soft_Links;
+
+ function To_Address is new
+ Unchecked_Conversion (Task_ID, System.Address);
+
+ function Tailored_Exception_Information
+ (E : Exception_Occurrence) return String;
+ pragma Import
+ (Ada, Tailored_Exception_Information,
+ "__gnat_tailored_exception_information");
+
+ begin
+ To_Stderr ("task ");
+
+ if Self_Id.Common.Task_Image /= null then
+ To_Stderr (Self_Id.Common.Task_Image.all);
+ 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));
+ end Notify_Exception;
+
+ ------------------
+ -- 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.
+ -- It also has some locally declared objects that server as per-task local
+ -- data. Task finalization is done by Complete_Task, which is called from
+ -- an at-end handler that the compiler generates.
+
+ -- 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.
+
+ -- The variable Magic_Number is also used in such implementations
+ -- of Self, to check whether the current task is an Ada task, as
+ -- compared to other-language threads.
+
+ -- Both act as constants, once initialized, but need to be marked as
+ -- volatile or aliased to prevent the compiler from optimizing away the
+ -- storage. See System.Task_Primitives.Operations.Self for more info.
+
+ procedure Task_Wrapper (Self_ID : Task_ID) is
+ ID : Task_ID := Self_ID;
+ pragma Volatile (ID);
+ -- Do not delete this variable.
+ -- In some targets, we need this variable to implement a fast Self.
+
+ Magic_Number : Interfaces.C.unsigned := 16#ADAADAAD#;
+ pragma Volatile (Magic_Number);
+ -- We use this to verify that we are looking at an Ada task,
+ -- inside of System.Task_Primitives.Operations.Self.
+
+ use type System.Parameters.Size_Type;
+ use type SSE.Storage_Offset;
+ use System.Standard_Library;
+
+ Secondary_Stack : aliased SSE.Storage_Array
+ (1 .. ID.Common.Compiler_Data.Pri_Stack_Info.Size *
+ SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
+ Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
+
+ begin
+ pragma Assert (Self_ID.Deferral_Level = 1);
+
+ if not Parameters.Sec_Stack_Dynamic then
+ ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address;
+ SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
+ 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.Known_Tasks_Index
+ -- and Self_ID.LL.Thread
+
+ Enter_Task (Self_ID);
+
+ -- We lock All_Tasks_L 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_All_Tasks_List;
+ Unlock_All_Tasks_List;
+
+ 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);
+
+ Terminate_Task (Self_ID);
+
+ exception
+ when Standard'Abort_Signal =>
+ Terminate_Task (Self_ID);
+
+ when others =>
+ -- ??? Using an E : others here causes CD2C11A to fail on
+ -- DEC Unix, see 7925-005.
+
+ if Exception_Trace = Unhandled_Raise then
+ Notify_Exception (Self_ID, SSL.Get_Current_Excep.all.all);
+ end if;
+
+ Terminate_Task (Self_ID);
+ end;
+ end Task_Wrapper;
+
+ --------------------
+ -- Terminate_Task --
+ --------------------
+
+ -- Before we allow the thread to exit, we must clean up. This is a
+ -- 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 last thing
+ -- done before the call to Exit_Task. 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_Abortion 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;
+
+ begin
+ pragma Assert (Self_ID.Common.Activator = null);
+
+ -- 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. See 6602-003 for more details.
+
+ if Self_ID.Common.Activator /= null then
+ Vulnerable_Complete_Task (Self_ID);
+ end if;
+
+ -- Check if the current task is an independent task
+ -- If so, decrement the Independent_Task_Count value.
+
+ if Self_ID.Master_of_Task = 2 then
+ Write_Lock (Environment_Task);
+ Utilities.Independent_Task_Count :=
+ Utilities.Independent_Task_Count - 1;
+ Unlock (Environment_Task);
+ end if;
+
+ -- Unprotect the guard page if needed.
+
+ Stack_Guard (Self_ID, False);
+
+ Initialization.Task_Lock (Self_ID);
+ Utilities.Make_Passive (Self_ID, Task_Completed => True);
+
+ 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.
+
+ STPO.Exit_Task;
+ end Terminate_Task;
+
+ ----------------
+ -- Terminated --
+ ----------------
+
+ function Terminated (T : Task_ID) return Boolean is
+ Result : Boolean;
+ Self_ID : Task_ID := STPO.Self;
+
+ begin
+ Initialization.Defer_Abort_Nestable (Self_ID);
+ Write_Lock (T);
+ Result := T.Common.State = Terminated;
+ Unlock (T);
+ Initialization.Undefer_Abort_Nestable (Self_ID);
+ return Result;
+ end Terminated;
+
+ ------------------------------------
+ -- Vulnerable_Complete_Activation --
+ ------------------------------------
+
+ -- Only call this procedure with abortion deferred.
+
+ -- 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 : 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 abortion, we do not raise an exception. ARM 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 : 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.
+
+ function Check_Unactivated_Tasks return Boolean is
+ begin
+ Lock_All_Tasks_List;
+ Write_Lock (Self_ID);
+ C := All_Tasks_List;
+
+ while C /= null loop
+ if C.Common.Activator = Self_ID 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);
+ Unlock_All_Tasks_List;
+ 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);
+
+ -- 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.
+
+ Lock_All_Tasks_List;
+ Write_Lock (Self_ID);
+ C := All_Tasks_List;
+
+ while C /= null loop
+ if C.Common.Activator = Self_ID then
+ pragma Assert (C.Common.State = Unactivated);
+
+ Write_Lock (C);
+ C.Common.Activator := null;
+ C.Common.State := Terminated;
+ C.Callable := False;
+ Cancel_Queued_Entry_Calls (C);
+ Unlock (C);
+ end if;
+
+ 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);
+ Unlock_All_Tasks_List;
+
+ -- 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 want
+ -- to abort the dependents, and resume waiting until Wait_Count goes
+ -- to zero.
+
+ Write_Lock (Self_ID);
+ loop
+ Initialization.Poll_Base_Priority_Change (Self_ID);
+ 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
+ Unlock (Self_ID);
+ Abort_Dependents (Self_ID);
+ Write_Lock (Self_ID);
+
+ 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 count of tasks that are on
+ -- terminate alternatives.
+
+ pragma Assert (Self_ID.Common.Wait_Count = 0);
+
+ -- Force any remaining dependents to terminate, by aborting them.
+
+ 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);
+
+ Lock_All_Tasks_List;
+ 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);
+ Unlock_All_Tasks_List;
+
+ -- Wait for all counted tasks to finish terminating themselves.
+
+ Write_Lock (Self_ID);
+
+ loop
+ Initialization.Poll_Base_Priority_Change (Self_ID);
+ 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 abortion here. We are already terminating
+ -- just as fast as we can, so there is no point.
+ -- ????
+ -- Consider whether we want to bother checking for priority
+ -- changes in the loop above, though.
+
+ -- 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.
+
+ Lock_All_Tasks_List;
+ 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_All_Tasks_List;
+
+ -- 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 Interrupt_Manager_ID /= null then
+ declare
+ Detach_Interrupt_Entries_Index : Task_Entry_Index := 6;
+ -- 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 > 3
+ 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. (That's why the
+ -- name has "Vulnerable" in it.) It should only be called by Complete_Task
+ -- and Finalizate_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);
+ 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'));
+
+ 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.
+
+ Cancel_Queued_Entry_Calls (Self_ID);
+ Unlock (Self_ID);
+
+ if Self_ID.Common.Activator /= null then
+ Vulnerable_Complete_Activation (Self_ID);
+ 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 can 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 Unchecked_Deallocation, for objects that
+ -- are or contain tasks.
+
+ procedure Vulnerable_Free_Task (T : Task_ID) is
+ begin
+ pragma Debug
+ (Debug.Trace ("Vulnerable_Free_Task", T, 'C'));
+
+ Write_Lock (T);
+ Initialization.Finalize_Attributes_Link.all (T);
+ Unlock (T);
+ if T.Common.Task_Image /= null then
+ Free_Task_Image (T.Common.Task_Image);
+ end if;
+ System.Task_Primitives.Operations.Finalize_TCB (T);
+ end Vulnerable_Free_Task;
+
+begin
+ -- Establish the Adafinal softlink.
+ -- 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 00000000000..913435a03fb
--- /dev/null
+++ b/gcc/ada/s-tassta.ads
@@ -0,0 +1,274 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.33 $
+-- --
+-- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+-- used for Task_Info_Type
+
+with System.Parameters;
+-- used for Size_Type
+
+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;
+ -- _init_proc (_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 _init_proc (_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, 0, _master,
+ -- task_procedure_access!(tB'address),
+ -- _init'address, tE'unchecked_access, _chain, _task_id, _init.
+ -- _task_id);
+ -- return;
+ -- end _init_proc;
+ -- ]
+ --
+ -- 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;
+ -- t1I : task_image_type := new string'"t1";
+ -- _init_proc (t1, _master, _chain, t1I, 1);
+ --
+ -- activate_tasks (_chain'unchecked_access);
+
+ procedure Abort_Tasks (Tasks : Task_List);
+ -- Compiler interface only. Do not call from within the RTS.
+ -- Initiate abortion, however, the actual abortion 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.
+
+ 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;
+ 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 : System.Task_Info.Task_Image_Type;
+ Created_Task : out 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)
+ -- 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.
+ -- 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 sucessfully 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 pointer to 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 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.
+
+ 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)
+
+end System.Tasking.Stages;
diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb
new file mode 100644
index 00000000000..af729643c15
--- /dev/null
+++ b/gcc/ada/s-tasuti.adb
@@ -0,0 +1,570 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.67 $
+-- --
+-- Copyright (C) 1991-2001, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+-- used for Known_Tasks
+
+with System.Task_Primitives.Operations;
+-- used for Write_Lock
+-- Set_Priority
+-- Wakeup
+-- Unlock
+-- Sleep
+-- Abort_Task
+-- Lock/Unlock_All_Tasks_List
+
+with System.Tasking.Initialization;
+-- Used for Defer_Abort
+-- Undefer_Abort
+-- Locked_Abort_To_Level
+
+with System.Tasking.Queuing;
+-- used for Dequeue_Call
+-- Dequeue_Head
+
+with System.Tasking.Debug;
+-- used for Trace
+
+with Unchecked_Conversion;
+
+package body System.Tasking.Utilities is
+
+ package STPO renames System.Task_Primitives.Operations;
+
+ use System.Tasking.Debug;
+ use System.Task_Primitives;
+ use System.Task_Primitives.Operations;
+
+ procedure Locked_Abort_To_Level
+ (Self_Id : Task_ID;
+ T : Task_ID;
+ L : ATC_Level)
+ renames
+ Initialization.Locked_Abort_To_Level;
+
+ procedure Defer_Abort (Self_Id : Task_ID) renames
+ System.Tasking.Initialization.Defer_Abort;
+
+ procedure Defer_Abort_Nestable (Self_Id : Task_ID) renames
+ System.Tasking.Initialization.Defer_Abort_Nestable;
+
+ procedure Undefer_Abort (Self_Id : Task_ID) renames
+ System.Tasking.Initialization.Undefer_Abort;
+
+ procedure Undefer_Abort_Nestable (Self_Id : Task_ID) renames
+ System.Tasking.Initialization.Undefer_Abort_Nestable;
+
+ procedure Wakeup_Entry_Caller
+ (Self_Id : Task_ID;
+ Entry_Call : Entry_Call_Link;
+ New_State : Entry_Call_State)
+ renames
+ Initialization.Wakeup_Entry_Caller;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ -- 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_One_Task
+ (Self_ID : Task_ID;
+ T : Task_ID)
+ is
+ begin
+ 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
+ Locked_Abort_To_Level (Self_ID, T, 0);
+ end if;
+
+ Unlock (T);
+ end Abort_One_Task;
+
+ -----------------
+ -- Abort_Tasks --
+ -----------------
+
+ -- Compiler interface only: Do not call from within the RTS,
+
+ -- except in the implementation of Ada.Task_Identification.
+ -- 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
+ -- ????
+ -- Since this is a "potentially blocking operation", we should
+ -- add a separate check here that we are not inside a protected
+ -- operation.
+
+ 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.
+
+ for J in Tasks'Range loop
+ C := Tasks (J);
+ Abort_One_Task (Self_Id, C);
+ end loop;
+
+ Lock_All_Tasks_List;
+ 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_All_Tasks_List;
+ Undefer_Abort_Nestable (Self_Id);
+ end Abort_Tasks;
+
+ -------------------------------
+ -- Cancel_Queued_Entry_Calls --
+ -------------------------------
+
+ -- Cancel any entry calls queued on target task. Call this only while
+ -- holding T locked, and nothing more. 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;
+ Caller : Task_ID;
+ Level : Integer;
+ Self_Id : constant Task_ID := STPO.Self;
+
+ 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);
+ 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 --
+ ----------------------
+
+ -- 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 only 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.
+
+ -- See procedures Init_RTS and Finalize_Global_Tasks for related code.
+
+ 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;
+
+ begin
+ if Self_Id.Known_Tasks_Index /= -1 then
+ Known_Tasks (Self_Id.Known_Tasks_Index) := null;
+ end if;
+
+ Defer_Abort (Self_Id);
+ Write_Lock (Environment_Task);
+ Write_Lock (Self_Id);
+
+ pragma Assert (Parent = Environment_Task
+ or else Self_Id.Master_of_Task = Library_Task_Level);
+
+ 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 can not 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;
+
+ Unlock (Environment_Task);
+ Undefer_Abort (Self_Id);
+ end Make_Independent;
+
+ ------------------
+ -- Make_Passive --
+ ------------------
+
+ -- Update counts to indicate current task is either terminated
+ -- or accepting on a terminate alternative. Call holding no locks.
+
+ 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;
+
+ pragma Assert (P.Awake_Count /= 0);
+
+ 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
+ pragma Assert (Self_ID.Awake_Count = 0);
+ 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.
+
+ P.Awake_Count := P.Awake_Count - 1;
+
+ 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 00000000000..6d605bc394a
--- /dev/null
+++ b/gcc/ada/s-tasuti.ads
@@ -0,0 +1,104 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.34 $ --
+-- --
+-- Copyright (C) 1991-1998 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides RTS Internal Declarations.
+-- These declarations are not part of the GNARLI
+
+with Unchecked_Conversion;
+
+package System.Tasking.Utilities is
+
+ function ATCB_To_Address is new
+ Unchecked_Conversion (Task_ID, System.Address);
+
+ ---------------------------------
+ -- Task_Stage Related routines --
+ ---------------------------------
+
+ procedure Make_Independent;
+ -- Move the current task to the outermost level (level 1) of the master
+ -- master hierarchy of the environment task. This is one level further
+ -- out than normal tasks defined in library-level packages (level 2).
+ -- The environment task will wait for level 2 tasks to terminate normally,
+ -- then it will abort all the level 1 tasks. See Finalize_Global_Tasks
+ -- procedure for more information.
+ --
+ -- This is a dangerous operation, and should only 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
+ -- GNARL, to prevent such internal server tasks from preventing a
+ -- partition from terminating.
+
+ 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 Abortion related routines --
+ ------------------------------------
+
+ procedure Cancel_Queued_Entry_Calls (T : Task_ID);
+ -- Cancel any entry calls queued on target task.
+ -- Do not call this while holding any locks.
+
+ 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 abortion, however, the actual
+ -- abortion is done by abortee 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.
+
+end System.Tasking.Utilities;
diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb
new file mode 100644
index 00000000000..a7109fbfd9a
--- /dev/null
+++ b/gcc/ada/s-tataat.adb
@@ -0,0 +1,225 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1995-1999 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+-- used for To_Address
+
+with System.Task_Primitives.Operations;
+-- used for Write_Lock
+-- Unlock
+-- Lock/Unlock_All_Tasks_List
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort
+-- Undefer_Abort
+
+with Unchecked_Conversion;
+
+package body System.Tasking.Task_Attributes is
+
+ use Task_Primitives.Operations,
+ System.Tasking.Initialization;
+
+ function To_Access_Node is new Unchecked_Conversion
+ (Access_Address, Access_Node);
+ -- Tetch pointer to indirect attribute list
+
+ function To_Access_Address is new 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;
+
+ begin
+ Defer_Abortion;
+ Write_Lock (All_Attrs_L'Access);
+
+ -- 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.
+
+ Lock_All_Tasks_List;
+
+ 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 the All_Tasks_L
+ -- lock.
+
+ Q.Next := To_Be_Freed;
+ To_Be_Freed := Q;
+ end if;
+
+ Unlock (C);
+ C := C.Common.All_Tasks_Link;
+ end loop;
+ end;
+
+ Unlock_All_Tasks_List;
+ end if;
+
+ Unlock (All_Attrs_L'Access);
+
+ while To_Be_Freed /= null loop
+ Q := To_Be_Freed;
+ To_Be_Freed := To_Be_Freed.Next;
+ X.Deallocate.all (Q);
+ end loop;
+
+ Undefer_Abortion;
+
+ 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.Task_Stages.Create_Task.
+ -- It relies on their being no concurrent access to this TCB,
+ -- so it does not defer abortion or lock T.L.
+
+ procedure Initialize_Attributes (T : Task_ID) is
+ P : Access_Instance;
+
+ begin
+ Write_Lock (All_Attrs_L'Access);
+
+ -- 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) :=
+ System.Storage_Elements.To_Address (P.Initial_Value);
+ end if;
+
+ P := P.Next;
+ end loop;
+
+ Unlock (All_Attrs_L'Access);
+
+ 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 00000000000..84463e477f3
--- /dev/null
+++ b/gcc/ada/s-tataat.ads
@@ -0,0 +1,121 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1995-2000 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides support for the body of Ada.Task_Attributes.
+
+with Ada.Finalization;
+-- used for Limited_Controlled
+
+with System.Storage_Elements;
+-- used for Integer_Address
+
+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;
+ type Dummy_Wrapper;
+ type Access_Dummy_Wrapper is access all Dummy_Wrapper;
+
+ 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
+ Noed : aliased Node;
+
+ Value : aliased Attribute;
+ -- The generic formal type, may be controlled
+ end record;
+
+ In_Use : Direct_Index_Vector := 0;
+ -- is True for direct indices that are already used.
+
+ All_Attributes : Access_Instance;
+ -- A linked list of all indirectly access attributes,
+ -- which includes all those that require finalization.
+
+ All_Attrs_L : aliased System.Task_Primitives.RTS_Lock;
+ -- Protects In_Use, Next_Indirect_Index, and All_Attributes.
+ -- Deadlock prevention order of locking:
+ -- 1) All_Attrs_L
+ -- 2) All_Tasks_L
+ -- 3) any TCB.L
+
+ 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, abortion 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, abortion must be deferred
+ -- and T.L must be write-locked.
+
+end System.Tasking.Task_Attributes;
diff --git a/gcc/ada/s-tpinop.adb b/gcc/ada/s-tpinop.adb
new file mode 100644
index 00000000000..80524e4d038
--- /dev/null
+++ b/gcc/ada/s-tpinop.adb
@@ -0,0 +1,83 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 . --
+-- I N T E R R U P T _ O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..ccb308d777d
--- /dev/null
+++ b/gcc/ada/s-tpinop.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 . --
+-- I N T E R R U P T _ O P E R A T I O N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1998 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Interrupt_Management;
+with System.Tasking;
+package System.Task_Primitives.Interrupt_Operations is
+
+ 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 00000000000..fa37450cef8
--- /dev/null
+++ b/gcc/ada/s-tpoben.adb
@@ -0,0 +1,248 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- E N T R I E S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.11 $
+-- --
+-- Copyright (C) 1991-2001, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.Exceptions;
+-- used for Exception_Occurrence_Access
+
+with System.Task_Primitives.Operations;
+-- used for Initialize_Lock
+-- Write_Lock
+-- Unlock
+-- Get_Priority
+-- Wakeup
+
+with System.Tasking.Initialization;
+-- used for Defer_Abort,
+-- Undefer_Abort,
+-- Change_Base_Priority
+
+pragma Elaborate_All (System.Tasking.Initialization);
+-- this insures 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 Ada.Exceptions;
+ use STPO;
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ --------------
+ -- Finalize --
+ --------------
+
+ 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 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);
+ STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ Raise_Exception (Program_Error'Identity, "Ceiling Violation");
+ 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;
+
+ Object.Finalized := True;
+ STPO.Unlock (Object.L'Unrestricted_Access);
+ STPO.Finalize_Lock (Object.L'Unrestricted_Access);
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : Protection_Entries_Access)
+ return Boolean
+ is
+ 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)
+ 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;
+
+ Initialization.Defer_Abort (Self_ID);
+ Initialize_Lock (Init_Priority, Object.L'Access);
+ Initialization.Undefer_Abort (Self_ID);
+ Object.Ceiling := System.Any_Priority (Init_Priority);
+ 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;
+ end Initialize_Protection_Entries;
+
+ ------------------
+ -- Lock_Entries --
+ ------------------
+
+ procedure Lock_Entries
+ (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is
+ begin
+ -- The lock is made without defering abortion.
+
+ -- Therefore the abortion 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 abortion, and compiler
+ -- generated calls must be protected with cleanup handlers to ensure
+ -- that abortion is undeferred in all cases.
+
+ pragma Assert (STPO.Self.Deferral_Level > 0);
+ Write_Lock (Object.L'Access, Ceiling_Violation);
+ end Lock_Entries;
+
+ procedure Lock_Entries (Object : Protection_Entries_Access) is
+ Ceiling_Violation : Boolean;
+ begin
+ pragma Assert (STPO.Self.Deferral_Level > 0);
+ Write_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ Raise_Exception (Program_Error'Identity, "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
+ Read_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ Raise_Exception (Program_Error'Identity, "Ceiling Violation");
+ end if;
+ end Lock_Read_Only_Entries;
+
+ --------------------
+ -- Unlock_Entries --
+ --------------------
+
+ procedure Unlock_Entries (Object : Protection_Entries_Access) is
+ begin
+ 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 00000000000..58b600d69a2
--- /dev/null
+++ b/gcc/ada/s-tpoben.ads
@@ -0,0 +1,189 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- E N T R I E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.12 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+-- Any changes to this interface may require corresponding compiler changes.
+
+with Ada.Finalization;
+-- used for Limited_Controlled
+
+with 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;
+ Call_In_Progress : Entry_Call_Link;
+ Ceiling : System.Any_Priority;
+ Old_Base_Priority : System.Any_Priority;
+ 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;
+
+ -- The following function maps the entry index in a call (which denotes
+ -- the queue to the proper entry) into the body of the entry.
+
+ Find_Body_Index : Find_Body_Index_Access;
+ Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+ end record;
+ pragma Volatile (Protection_Entries);
+
+ -- 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_Protection_Entries is new Unchecked_Conversion
+ (Protection_Access, Protection_Entries_Access);
+
+ function To_Address is
+ new Unchecked_Conversion (Protection_Entries_Access, System.Address);
+ function To_Protection is
+ new Unchecked_Conversion (System.Address, Protection_Entries_Access);
+
+ 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 overriden 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);
+ -- 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 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
+
+ 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 00000000000..2e865821bc9
--- /dev/null
+++ b/gcc/ada/s-tpobop.adb
@@ -0,0 +1,981 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1991-2001, 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+
+-- This package contains all primitives related to Protected_Objects.
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+
+with Ada.Exceptions;
+-- Used for Exception_ID
+-- Null_Id
+-- Raise_Exception
+
+with System.Task_Primitives.Operations;
+-- used for Initialize_Lock
+-- Write_Lock
+-- Unlock
+-- Get_Priority
+-- Wakeup
+
+with System.Tasking.Entry_Calls;
+-- used for Wait_For_Completion
+-- Wait_Until_Abortable
+
+with System.Tasking.Initialization;
+-- Used for Defer_Abort,
+-- Undefer_Abort,
+-- Change_Base_Priority
+
+pragma Elaborate_All (System.Tasking.Initialization);
+-- This insures that tasking is initialized if any protected objects are
+-- created.
+
+with System.Tasking.Queuing;
+-- used for Enqueue
+-- Broadcast_Program_Error
+-- Select_Protected_Entry_Call
+-- Onqueue
+-- Count_Waiting
+
+with System.Tasking.Rendezvous;
+-- used for Task_Do_Or_Queue
+
+with System.Tasking.Debug;
+-- used for Trace
+
+package body System.Tasking.Protected_Objects.Operations is
+
+ package STPO renames System.Task_Primitives.Operations;
+
+ use Task_Primitives;
+ use Tasking;
+ use Ada.Exceptions;
+ use Entries;
+
+ -----------------------
+ -- 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.
+
+ ---------------------------------
+ -- 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;
+ -- _init_proc (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 both
+ -- Cancel_Protected_Entry_Call and 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
+ Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
+
+ 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;
+
+-- ?????
+-- The caller should do the following, after return from this
+-- procedure, if Call_In_Progress /= null
+-- Write_Lock (Entry_Call.Self);
+-- Initialization.Wakeup_Entry_Caller (STPO.Self, Entry_Call, Done);
+-- Unlock (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;
+ With_Abort : Boolean)
+ is
+ E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E);
+ New_Object : Protection_Entries_Access;
+ Ceiling_Violation : Boolean;
+ 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;
+ Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
+
+ else
+ -- Body of current entry requeued the call
+ New_Object := To_Protection (Entry_Call.Called_PO);
+
+ if New_Object = null then
+
+ -- Call was requeued to a task
+
+ if not Rendezvous.Task_Do_Or_Queue
+ (Self_ID, Entry_Call,
+ With_Abort => Entry_Call.Requeue_With_Abort)
+ then
+ Queuing.Broadcast_Program_Error
+ (Self_ID, Object, Entry_Call);
+ end if;
+ return;
+ end if;
+
+ if Object /= New_Object then
+ -- Requeue is on a different object
+
+ 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, With_Abort);
+ PO_Service_Entries (Self_ID, New_Object);
+ Unlock_Entries (New_Object);
+ end if;
+
+ else
+ -- Requeue is on same protected object
+
+ if Entry_Call.Requeue_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 With_Abort or else
+ Entry_Call.Mode /= Conditional_Call
+ then
+ E := Protected_Entry_Index (Entry_Call.E);
+ Queuing.Enqueue
+ (New_Object.Entry_Queues (E), Entry_Call);
+ Update_For_Queue_To_PO (Entry_Call, With_Abort);
+
+ else
+ -- ?????
+ -- Can we convert this recursion to a loop?
+
+ PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort);
+ end if;
+ end if;
+ end if;
+
+ elsif Entry_Call.Mode /= Conditional_Call or else
+ not With_Abort then
+ Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
+ Update_For_Queue_To_PO (Entry_Call, With_Abort);
+
+ else
+ -- Conditional_Call and With_Abort
+
+ 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);
+ 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 : Protection_Entries_Access)
+ is
+ Entry_Call : Entry_Call_Link;
+ E : Protected_Entry_Index;
+ Caller : Task_ID;
+ New_Object : Protection_Entries_Access;
+ Ceiling_Violation : Boolean;
+
+ begin
+ loop
+ Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
+
+ if Entry_Call /= null then
+ 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
+ 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
+ Object.Call_In_Progress := null;
+ Caller := Entry_Call.Self;
+ STPO.Write_Lock (Caller);
+ Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
+ STPO.Unlock (Caller);
+
+ else
+ -- Call needs to be requeued
+
+ New_Object := To_Protection (Entry_Call.Called_PO);
+
+ if New_Object = null then
+
+ -- Call is to be requeued to a task entry
+
+ if not Rendezvous.Task_Do_Or_Queue
+ (Self_ID, Entry_Call,
+ With_Abort => Entry_Call.Requeue_With_Abort)
+ then
+ Queuing.Broadcast_Program_Error
+ (Self_ID, Object, Entry_Call);
+ 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,
+ Entry_Call.Requeue_With_Abort);
+ PO_Service_Entries (Self_ID, New_Object);
+ Unlock_Entries (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.Requeue_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;
+ exit;
+ end if;
+
+ if not Entry_Call.Requeue_With_Abort or else
+ Entry_Call.Mode /= Conditional_Call
+ then
+ E := Protected_Entry_Index (Entry_Call.E);
+ Queuing.Enqueue
+ (New_Object.Entry_Queues (E), Entry_Call);
+ Update_For_Queue_To_PO (Entry_Call,
+ Entry_Call.Requeue_With_Abort);
+
+ else
+ PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call,
+ Entry_Call.Requeue_With_Abort);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ else
+ exit;
+ end if;
+ end loop;
+ 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;
+ -- _init_proc (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
+ -- 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 : 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 Self_ID.ATC_Nesting_Level = ATC_Level'Last then
+ Raise_Exception (Storage_Error'Identity,
+ "not enough ATC nesting levels");
+ end if;
+
+ Initialization.Defer_Abort (Self_ID);
+ Lock_Entries (Object, Ceiling_Violation);
+
+ if Ceiling_Violation then
+
+ -- Failed ceiling check
+
+ Initialization.Undefer_Abort (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;
+
+ if Self_ID.Deferral_Level > 1 then
+ Entry_Call.State := Never_Abortable;
+ else
+ Entry_Call.State := Now_Abortable;
+ end if;
+
+ 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;
+
+ PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
+ Initially_Abortable := Entry_Call.State = Now_Abortable;
+ PO_Service_Entries (Self_ID, Object);
+
+ Unlock_Entries (Object);
+
+ -- Try to prevent waiting later (in 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.
+
+ Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
+ pragma Debug
+ (Debug.Trace (Self_ID, "PEC: exited to ATC level: " &
+ ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
+ Block.Enqueued := False;
+ Block.Cancelled := Entry_Call.State = Cancelled;
+ Initialization.Undefer_Abort (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
+ Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
+ end if;
+
+ elsif Mode < Asynchronous_Call then
+
+ -- Simple_Call or Conditional_Call
+
+ STPO.Write_Lock (Self_ID);
+ Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call);
+ STPO.Unlock (Self_ID);
+ Block.Cancelled := Entry_Call.State = Cancelled;
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+
+ Initialization.Undefer_Abort (Self_ID);
+ Entry_Calls.Check_Exception (Self_ID, Entry_Call);
+
+ end Protected_Entry_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.Requeue_With_Abort := With_Abort;
+ Object.Call_In_Progress := null;
+ end Requeue_Protected_Entry;
+
+ -------------------------------------
+ -- Requeue_Task_To_Protected_Entry --
+ -------------------------------------
+
+ -- Compiler interface only.
+
+ -- 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;
+ -- <<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);
+ STPO.Write_Lock (Self_ID);
+ Entry_Call.Needs_Requeue := True;
+ Entry_Call.Requeue_With_Abort := With_Abort;
+ Entry_Call.Called_PO := To_Address (New_Object);
+ Entry_Call.Called_Task := null;
+ STPO.Unlock (Self_ID);
+ Entry_Call.E := Entry_Index (E);
+ Initialization.Undefer_Abort (Self_ID);
+ end Requeue_Task_To_Protected_Entry;
+
+ -- ??????
+ -- Do we really need to lock Self_ID above?
+ -- Might the caller be trying to cancel?
+ -- If so, it should fail, since the call state should not be
+ -- abortable while the call is in service.
+
+ ---------------------
+ -- 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 : Task_ID := STPO.Self;
+ Entry_Call : Entry_Call_Link;
+ Ceiling_Violation : Boolean;
+
+ begin
+ if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
+ Raise_Exception (Storage_Error'Identity,
+ "not enough ATC nesting levels");
+ end if;
+
+ Initialization.Defer_Abort (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;
+
+ if Self_ID.Deferral_Level > 1 then
+ Entry_Call.State := Never_Abortable;
+ else
+ Entry_Call.State := Now_Abortable;
+ end if;
+
+ 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;
+
+ PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
+ PO_Service_Entries (Self_ID, Object);
+
+ Unlock_Entries (Object);
+
+ -- Try to avoid waiting for completed or cancelled calls.
+
+ if Entry_Call.State >= Done then
+ 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_Successful := Entry_Call.State = Done;
+ Initialization.Undefer_Abort (Self_ID);
+ Entry_Calls.Check_Exception (Self_ID, Entry_Call);
+ return;
+ end if;
+
+ Entry_Calls.Wait_For_Completion_With_Timeout
+ (Self_ID, Entry_Call, Timeout, Mode);
+ Initialization.Undefer_Abort (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 : 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
+ 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);
+ 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 00000000000..6ffeeea75c6
--- /dev/null
+++ b/gcc/ada/s-tpobop.ads
@@ -0,0 +1,207 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 . --
+-- O P E R A T I O N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+-- used for Exception_Id
+
+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);
+ -- 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 abortion deferred and with the corresponding
+ -- object locked.
+
+ 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;
+ With_Abort : Boolean);
+ -- This procedure either executes or queues an entry call, depending
+ -- on the status of the corresponding barrier. It assumes that abortion
+ -- 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);
+
+ -- ?????
+ -- 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-tposen.adb b/gcc/ada/s-tposen.adb
new file mode 100644
index 00000000000..dcecc3163d9
--- /dev/null
+++ b/gcc/ada/s-tposen.adb
@@ -0,0 +1,599 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 I N G L E _ E N T R Y --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1998-2001 Ada Core Technologies --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 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
+-- 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,
+-- PO_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);
+
+with System.Task_Primitives.Operations;
+-- used for Self
+-- Finalize_Lock
+-- Write_Lock
+-- Unlock
+
+with Ada.Exceptions;
+-- used for Exception_Id;
+
+with Unchecked_Conversion;
+
+package body System.Tasking.Protected_Objects.Single_Entry is
+
+ package STPO renames System.Task_Primitives.Operations;
+
+ function To_Address is new
+ Unchecked_Conversion (Protection_Entry_Access, System.Address);
+
+ -----------------------
+ -- 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
+ (Self_ID : Task_ID;
+ 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
+ (Self_ID : Task_ID;
+ 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.
+ -- Self_ID will be locked by this procedure.
+
+ 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);
+
+ ---------------------
+ -- Check_Exception --
+ ---------------------
+
+ procedure Check_Exception
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link)
+ is
+ 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
+ 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;
+ STPO.Write_Lock (Caller);
+ Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ STPO.Unlock (Caller);
+ end Send_Program_Error;
+
+ -------------------------
+ -- Wait_For_Completion --
+ -------------------------
+
+ -- Call this only when holding Self_ID locked
+
+ procedure Wait_For_Completion
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link)
+ is
+ begin
+ pragma Assert (Self_ID = Entry_Call.Self);
+ 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 --
+ --------------------------------------
+
+ -- This routine will lock Self_ID.
+
+ -- 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.
+
+ procedure Wait_For_Completion_With_Timeout
+ (Self_ID : Task_ID;
+ Entry_Call : Entry_Call_Link;
+ Wakeup_Time : Duration;
+ Mode : Delay_Modes)
+ is
+ Timedout : Boolean;
+ Yielded : Boolean;
+
+ use type Ada.Exceptions.Exception_Id;
+
+ begin
+ STPO.Write_Lock (Self_ID);
+
+ pragma Assert (Entry_Call.Self = Self_ID);
+ 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);
+
+ if Timedout then
+ Entry_Call.State := Cancelled;
+ else
+ Entry_Call.State := Done;
+ end if;
+
+ Self_ID.Common.State := Runnable;
+ STPO.Unlock (Self_ID);
+ 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
+ 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
+ begin
+ -- Nothing needs to be done since
+ -- 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
+ Init_Priority : Integer := Ceiling_Priority;
+
+ begin
+ if Init_Priority = Unspecified_Priority then
+ Init_Priority := System.Priority'Last;
+ end if;
+
+ STPO.Initialize_Lock (Init_Priority, Object.L'Access);
+ Object.Ceiling := System.Any_Priority (Init_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
+ Ceiling_Violation : Boolean;
+ begin
+ STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ raise Program_Error;
+ end if;
+ 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
+ Ceiling_Violation : Boolean;
+ begin
+ STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ raise Program_Error;
+ end if;
+ 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;
+ Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+
+ elsif Entry_Call.Mode /= Conditional_Call then
+ Object.Entry_Queue := Entry_Call;
+ else
+ -- Conditional_Call
+
+ STPO.Write_Lock (Entry_Call.Self);
+ Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
+ STPO.Unlock (Entry_Call.Self);
+ end if;
+
+ exception -- not needed in no exc mode
+ when others => -- not needed in no exc mode
+ Send_Program_Error -- not needed in no exc mode
+ (Self_Id, Entry_Call); -- not needed in no exc mode
+ end PO_Do_Or_Queue;
+
+ ----------------------------
+ -- Protected_Single_Count --
+ ----------------------------
+
+ function Protected_Count_Entry
+ (Object : Protection_Entry) return Natural is
+ begin
+ if Object.Call_In_Progress /= 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);
+ Ceiling_Violation : Boolean;
+
+ begin
+ STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ raise Program_Error;
+ end if;
+
+ 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
+ Check_Exception (Self_Id, Entry_Call'Access);
+ return;
+ end if;
+
+ STPO.Write_Lock (Self_Id);
+ Wait_For_Completion (Self_Id, Entry_Call'Access);
+ STPO.Unlock (Self_Id);
+ 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 : Entry_Call_Link;
+ Caller : Task_ID;
+ Barrier_Value : Boolean;
+
+ begin
+ Entry_Call := Object.Entry_Queue;
+
+ if Entry_Call /= null then
+ 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;
+ Caller := Entry_Call.Self;
+ STPO.Write_Lock (Caller);
+ Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ STPO.Unlock (Caller);
+ end if;
+ end if;
+
+ exception -- not needed in no exc mode
+ when others => -- not needed in no exc mode
+ Send_Program_Error -- not needed in no exc mode
+ (Self_Id, Entry_Call); -- not needed in no exc mode
+ 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);
+ Ceiling_Violation : Boolean;
+
+ begin
+ STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
+
+ if Ceiling_Violation then
+ raise Program_Error;
+ end if;
+
+ 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;
+
+ Wait_For_Completion_With_Timeout
+ (Self_Id, Entry_Call'Access, Timeout, Mode);
+
+ 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
+ STPO.Unlock (Object.L'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 00000000000..9ae62378065
--- /dev/null
+++ b/gcc/ada/s-tposen.ads
@@ -0,0 +1,295 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 I N G L E _ E N T R Y --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1991-1999 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, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 _init_proc (_init : in out poTV) is
+ -- begin
+ -- _init.open := false;
+ -- _init_proc (_init._object);
+ -- initialize_protection_entry (_init._object'unchecked_access,
+ -- unspecified_priority, _init'address, poTA'
+ -- unrestricted_access);
+ -- return;
+ -- end _init_proc;
+ -- ]
+ -- po : poT;
+ -- _init_proc (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 cals 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 abortion deferred and with the corresponding
+ -- object locked.
+
+ 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
+ L : aliased Task_Primitives.Lock;
+ Compiler_Info : System.Address;
+ Call_In_Progress : Entry_Call_Link;
+ Ceiling : System.Any_Priority;
+ Entry_Body : Entry_Body_Access;
+ Entry_Queue : Entry_Call_Link;
+ end record;
+ pragma Volatile (Protection_Entry);
+ for Protection_Entry'Alignment use Standard'Maximum_Alignment;
+ -- Use maximum alignement so that one can convert a protection_entry_access
+ -- to a task_id.
+
+end System.Tasking.Protected_Objects.Single_Entry;
diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb
new file mode 100644
index 00000000000..65d6cd0df9f
--- /dev/null
+++ b/gcc/ada/s-traceb.adb
@@ -0,0 +1,79 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default version of this package
+
+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)
+ return Integer;
+ pragma Import (C, Backtrace, "__gnat_backtrace");
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min,
+ Exclude_Max : System.Address := System.Null_Address)
+ is
+ begin
+ Len := Backtrace (Traceback, Max_Len, Exclude_Min, Exclude_Max);
+ 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 00000000000..13f0e88728d
--- /dev/null
+++ b/gcc/ada/s-traceb.ads
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 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);
+ -- 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 actual 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.
+ --
+ -- 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-unstyp.ads b/gcc/ada/s-unstyp.ads
new file mode 100644
index 00000000000..0b315a84c1f
--- /dev/null
+++ b/gcc/ada/s-unstyp.ads
@@ -0,0 +1,234 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . U N S I G N E D _ T Y P E S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.20 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 only by the expander.
+
+package System.Unsigned_Types is
+pragma Pure (Unsigned_Types);
+
+ 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_Butes array
+
+ type Packed_Bytes1 is array (Natural range <>) of Packed_Byte;
+ for Packed_Bytes1'Alignment use 1;
+ -- 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 2;
+ -- This is the type used to implement packed arrays where an alignment
+ -- of 2 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 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 instrinsic (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 obsolsecent. 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-vaflop.adb b/gcc/ada/s-vaflop.adb
new file mode 100644
index 00000000000..069188c6dc8
--- /dev/null
+++ b/gcc/ada/s-vaflop.adb
@@ -0,0 +1,421 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.20 $
+-- --
+-- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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; use System.IO;
+
+package body System.Vax_Float_Operations is
+
+ -----------
+ -- 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
+ Put (D'Image (Arg));
+ end Debug_Output_D;
+
+ --------------------
+ -- Debug_Output_F --
+ --------------------
+
+ procedure Debug_Output_F (Arg : F) is
+ begin
+ Put (F'Image (Arg));
+ end Debug_Output_F;
+
+ --------------------
+ -- Debug_Output_G --
+ --------------------
+
+ procedure Debug_Output_G (Arg : G) is
+ begin
+ 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;
+
+ -----------
+ -- 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
+ Put_Line (D'Image (Arg));
+ end pd;
+
+ --------
+ -- pf --
+ --------
+
+ procedure pf (Arg : F) is
+ begin
+ Put_Line (F'Image (Arg));
+ end pf;
+
+ --------
+ -- pg --
+ --------
+
+ procedure pg (Arg : G) is
+ begin
+ 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;
+
+ -----------
+ -- 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;
+
+end System.Vax_Float_Operations;
diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads
new file mode 100644
index 00000000000..5f22cffdc04
--- /dev/null
+++ b/gcc/ada/s-vaflop.ads
@@ -0,0 +1,215 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.13 $ --
+-- --
+-- Copyright (C) 1997-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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
+
+ ----------------------
+ -- 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 supercede 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 (D_To_G);
+ pragma Inline (F_To_G);
+ pragma Inline (F_To_Q);
+ pragma Inline (F_To_S);
+ pragma Inline (G_To_D);
+ pragma Inline (G_To_F);
+ pragma Inline (G_To_Q);
+ pragma Inline (G_To_T);
+ pragma Inline (Q_To_F);
+ pragma Inline (Q_To_G);
+ pragma Inline (S_To_F);
+ pragma Inline (T_To_G);
+
+ pragma Inline (Abs_F);
+ pragma Inline (Abs_G);
+ pragma Inline (Add_F);
+ pragma Inline (Add_G);
+ pragma Inline (Div_G);
+ pragma Inline (Div_F);
+ pragma Inline (Mul_F);
+ pragma Inline (Mul_G);
+ pragma Inline (Neg_G);
+ pragma Inline (Neg_F);
+ pragma Inline (Sub_F);
+ pragma Inline (Sub_G);
+
+ pragma Inline (Eq_F);
+ pragma Inline (Eq_G);
+ pragma Inline (Le_F);
+ pragma Inline (Le_G);
+ pragma Inline (Lt_F);
+ pragma Inline (Lt_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 00000000000..c74b07a91f8
--- /dev/null
+++ b/gcc/ada/s-valboo.adb
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ B O O L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+ end if;
+
+ if S (F .. L) = "FALSE" then
+ return False;
+ end if;
+
+ raise Constraint_Error;
+
+ -- Above should use elsif, but this doesn't work in GNAT version 1.81???
+
+ 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 00000000000..d28cb1b9a6e
--- /dev/null
+++ b/gcc/ada/s-valboo.ads
@@ -0,0 +1,42 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ B O O L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System.Val_Bool is
+pragma Pure (Val_Bool);
+
+ 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 00000000000..31bcbd3e91c
--- /dev/null
+++ b/gcc/ada/s-valcha.adb
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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;
+
+ 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 00000000000..4eba148d325
--- /dev/null
+++ b/gcc/ada/s-valcha.ads
@@ -0,0 +1,42 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System.Val_Char is
+pragma Pure (Val_Char);
+
+ 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 00000000000..5ae8a502bbe
--- /dev/null
+++ b/gcc/ada/s-valdec.adb
@@ -0,0 +1,74 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ D E C --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : 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 00000000000..38e8a326ede
--- /dev/null
+++ b/gcc/ada/s-valdec.ads
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ D E C --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Val_Dec);
+
+ function Scan_Decimal
+ (Str : String;
+ Ptr : 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 00000000000..8c9a040c750
--- /dev/null
+++ b/gcc/ada/s-valenu.adb
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.12 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with 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 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 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 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 00000000000..e9c39115aad
--- /dev/null
+++ b/gcc/ada/s-valenu.ads
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Val_Enum);
+
+ 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 00000000000..2807b767aa8
--- /dev/null
+++ b/gcc/ada/s-valint.adb
@@ -0,0 +1,101 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ I N T --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : 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);
+ Uval := Scan_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 00000000000..b58b04c3e6e
--- /dev/null
+++ b/gcc/ada/s-valint.ads
@@ -0,0 +1,78 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ I N T --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Val_Int);
+
+ function Scan_Integer
+ (Str : String;
+ Ptr : 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 00000000000..91610351850
--- /dev/null
+++ b/gcc/ada/s-vallld.adb
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ L L D --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : 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 00000000000..9e7b0a955d4
--- /dev/null
+++ b/gcc/ada/s-vallld.ads
@@ -0,0 +1,87 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ L L D --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Val_LLD);
+
+ function Scan_Long_Long_Decimal
+ (Str : String;
+ Ptr : 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 00000000000..902812ba017
--- /dev/null
+++ b/gcc/ada/s-vallli.adb
@@ -0,0 +1,103 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ L L I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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
+
+ ---------------------------
+ -- Scn_Long_Long_Integer --
+ ---------------------------
+
+ function Scan_Long_Long_Integer
+ (Str : String;
+ Ptr : 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);
+ Uval := Scan_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 00000000000..adbda0b0ef1
--- /dev/null
+++ b/gcc/ada/s-vallli.ads
@@ -0,0 +1,78 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ L L I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Val_LLI);
+
+ function Scan_Long_Long_Integer
+ (Str : String;
+ Ptr : 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 00000000000..444d0fd8110
--- /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 --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.12 $ --
+-- --
+-- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+
+package body System.Val_LLU is
+
+ -----------------------------
+ -- Scan_Long_Long_Unsigned --
+ -----------------------------
+
+ function Scan_Long_Long_Unsigned
+ (Str : String;
+ Ptr : 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
+
+ Minus : Boolean := False;
+ -- Set to True if minus sign is present, otherwise to False. Note that
+ -- a minus sign is permissible for the singular case of -0, and in any
+ -- case the pointer is left pointing past a negative integer literal.
+
+ Overflow : Boolean := False;
+ -- Set True if overflow is detected at any point
+
+ Start : Positive;
+ -- Save location of first non-blank character
+
+ 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
+ Scan_Sign (Str, Ptr, Max, Minus, Start);
+
+ if Str (Ptr.all) not in '0' .. '9' then
+ Ptr.all := Start;
+ raise Constraint_Error;
+ end if;
+
+ P := Ptr.all;
+ Uval := Character'Pos (Str (P)) - Character'Pos ('0');
+ P := P + 1;
+
+ -- Scan out digits of what is either the number or the base.
+ -- In either case, we are definitely scanning out in base 10.
+
+ declare
+ Umax : constant := (Long_Long_Unsigned'Last - 9) / 10;
+ -- Max value which cannot overflow on accumulating next digit
+
+ Umax10 : constant := Long_Long_Unsigned'Last / 10;
+ -- Numbers bigger than Umax10 overflow if multiplied by 10
+
+ begin
+ -- Loop through decimal digits
+ loop
+ exit when P > Max;
+
+ Digit := Character'Pos (Str (P)) - Character'Pos ('0');
+
+ -- Non-digit encountered
+
+ if Digit > 9 then
+ if Str (P) = '_' then
+ Scan_Underscore (Str, P, Ptr, Max, False);
+ else
+ exit;
+ end if;
+
+ -- Accumulate result, checking for overflow
+
+ else
+ if Uval <= Umax then
+ Uval := 10 * Uval + Digit;
+
+ elsif Uval > Umax10 then
+ Overflow := True;
+
+ else
+ Uval := 10 * Uval + Digit;
+
+ if Uval < Umax10 then
+ Overflow := True;
+ end if;
+ end if;
+
+ P := P + 1;
+ end if;
+ end loop;
+ end;
+
+ Ptr.all := P;
+
+ -- Deal with based case
+
+ 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 or else (Minus and then Uval /= 0) then
+ raise Constraint_Error;
+ else
+ return Uval;
+ end if;
+ 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 00000000000..897bc36304b
--- /dev/null
+++ b/gcc/ada/s-valllu.ads
@@ -0,0 +1,83 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ L L U --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning unsigned 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 (Val_LLU);
+
+ function Scan_Long_Long_Unsigned
+ (Str : String;
+ Ptr : 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). 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 that if a minus sign is present, and
+ -- the integer value is non-zero, then constraint error will be 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_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 00000000000..8ed11d515bc
--- /dev/null
+++ b/gcc/ada/s-valrea.adb
@@ -0,0 +1,336 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ R E A L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.18 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : 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
+
+ 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.
+
+ procedure Scanf is
+ Digit : Natural;
+
+ begin
+ loop
+ Digit := Character'Pos (Str (P)) - Character'Pos ('0');
+ Uval := Uval * 10.0 + Long_Long_Float (Digit);
+ P := P + 1;
+ Scale := Scale - After_Point;
+
+ -- 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;
+ 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
+ raise Constraint_Error;
+
+ 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
+ raise Constraint_Error;
+ end if;
+
+ P := P + 1;
+ Fdigit := Long_Long_Float (Digit);
+
+ if Fdigit >= Base then
+ Bad_Base := True;
+ else
+ Scale := Scale - After_Point;
+ Uval := Uval * Base + Fdigit;
+ end if;
+
+ if P > Max then
+ raise Constraint_Error;
+
+ 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
+ raise Constraint_Error;
+ 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
+ raise Constraint_Error;
+
+ -- 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 00000000000..8a35e9eb63a
--- /dev/null
+++ b/gcc/ada/s-valrea.ads
@@ -0,0 +1,75 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ R E A L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package System.Val_Real is
+pragma Pure (Val_Real);
+
+ function Scan_Real
+ (Str : String;
+ Ptr : 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 00000000000..f3f552f9502
--- /dev/null
+++ b/gcc/ada/s-valuns.adb
@@ -0,0 +1,298 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ U N S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $ --
+-- --
+-- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Unsigned_Types; use System.Unsigned_Types;
+with System.Val_Util; use System.Val_Util;
+
+package body System.Val_Uns is
+
+ -------------------
+ -- Scan_Unsigned --
+ -------------------
+
+ function Scan_Unsigned
+ (Str : String;
+ Ptr : access Integer;
+ Max : Integer)
+ return Unsigned
+ is
+ P : Integer;
+ -- Local copy of the pointer
+
+ Uval : Unsigned;
+ -- Accumulated unsigned integer result
+
+ Expon : Integer;
+ -- Exponent value
+
+ Minus : Boolean := False;
+ -- Set to True if minus sign is present, otherwise to False. Note that
+ -- a minus sign is permissible for the singular case of -0, and in any
+ -- case the pointer is left pointing past a negative integer literal.
+
+ Overflow : Boolean := False;
+ -- Set True if overflow is detected at any point
+
+ Start : Positive;
+ -- Save location of first non-blank character
+
+ Base_Char : Character;
+ -- Base character (# or :) in based case
+
+ Base : Unsigned := 10;
+ -- Base value (reset in based case)
+
+ Digit : Unsigned;
+ -- Digit value
+
+ 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;
+
+ 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 or else (Minus and then Uval /= 0) then
+ raise Constraint_Error;
+ else
+ return Uval;
+ end if;
+ 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 00000000000..cc732815f3f
--- /dev/null
+++ b/gcc/ada/s-valuns.ads
@@ -0,0 +1,83 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ U N S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.9 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines for scanning modular Unsigned
+-- values for use in Text_IO.Modular, and the Value attribute.
+
+with System.Unsigned_Types;
+
+package System.Val_Uns is
+pragma Pure (Val_Uns);
+
+ function Scan_Unsigned
+ (Str : String;
+ Ptr : 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). 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 that if a minus sign is present, and
+ -- the integer value is non-zero, then constraint error will be 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_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 00000000000..52eeea956dc
--- /dev/null
+++ b/gcc/ada/s-valuti.adb
@@ -0,0 +1,289 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ U T I L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Case_Util; use GNAT.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 : 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_Sign --
+ ---------------
+
+ procedure Scan_Sign
+ (Str : String;
+ Ptr : 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 : 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 undescore.
+ -- 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 00000000000..23c62253f13
--- /dev/null
+++ b/gcc/ada/s-valuti.ads
@@ -0,0 +1,110 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ U T I L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides some common utilities used by the s-valxxx files
+
+package System.Val_Util is
+pragma Pure (Val_Util);
+
+ 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 : 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.
+
+ function Scan_Exponent
+ (Str : String;
+ Ptr : 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 : 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 00000000000..429377faf7b
--- /dev/null
+++ b/gcc/ada/s-valwch.adb
@@ -0,0 +1,114 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ W C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992-1997, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.Val_Util; use System.Val_Util;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_StW; use System.WCh_StW;
+
+package body System.Val_WChar is
+
+ --------------------------
+ -- Value_Wide_Character --
+ --------------------------
+
+ function Value_Wide_Character
+ (Str : String;
+ EM : WC_Encoding_Method)
+ return 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
+
+ -- If just three characters, simple character case
+
+ if L - F = 2 then
+ return Wide_Character'Val (Character'Pos (S (F + 1)));
+
+ -- Otherwise must be a wide character in quotes. The easiest
+ -- thing is to convert the string to a wide string and then
+ -- pick up the single character that it should contain.
+
+ else
+ declare
+ WS : constant Wide_String :=
+ String_To_Wide_String (S (F + 1 .. L - 1), EM);
+
+ begin
+ if WS'Length /= 1 then
+ raise Constraint_Error;
+
+ else
+ return WS (WS'First);
+ end if;
+ end;
+ end if;
+
+ -- the last two values of the type have language-defined names:
+
+ elsif S = "FFFE" then
+ return Wide_Character'Val (16#FFFE#);
+
+ elsif S = "FFFF" then
+ return Wide_Character'Val (16#FFFF#);
+
+ -- Otherwise must be a control character
+
+ else
+ for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop
+ if S (F .. L) = Character'Image (C) then
+ return Wide_Character'Val (Character'Pos (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 Wide_Character'Val (Character'Pos (C));
+ end if;
+ end loop;
+
+ raise Constraint_Error;
+ end if;
+
+ end Value_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 00000000000..8adb83bf710
--- /dev/null
+++ b/gcc/ada/s-valwch.ads
@@ -0,0 +1,47 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ W C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.2 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.WCh_Con;
+
+package System.Val_WChar is
+pragma Pure (Val_WChar);
+
+ function Value_Wide_Character
+ (Str : String;
+ EM : System.WCh_Con.WC_Encoding_Method)
+ return Wide_Character;
+ -- Computes Wide_Character'Value (Str).
+
+end System.Val_WChar;
diff --git a/gcc/ada/s-vercon.adb b/gcc/ada/s-vercon.adb
new file mode 100644
index 00000000000..a7d712d4eda
--- /dev/null
+++ b/gcc/ada/s-vercon.adb
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME 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 --
+-- --
+-- $Revision: 1.2 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : 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 00000000000..dceba430451
--- /dev/null
+++ b/gcc/ada/s-vercon.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME 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 --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Version_Control);
+
+ 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 00000000000..2be1ae1ada2
--- /dev/null
+++ b/gcc/ada/s-vmexta.adb
@@ -0,0 +1,164 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.7 $
+-- --
+-- Copyright (C) 1997-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an Alpha/VMS package.
+
+with GNAT.HTable;
+pragma Elaborate_All (GNAT.HTable);
+
+package body System.VMS_Exception_Table is
+
+ use System.Standard_Library;
+
+ 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 : Natural;
+ Except : 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 : Natural) return HTable_Headers;
+ function Get_Key (T : Exception_Code_Data_Ptr) return Natural;
+
+ package Exception_Code_HTable is new GNAT.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 => Natural,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => "=");
+
+ ---------------------
+ -- Coded_Exception --
+ ---------------------
+
+ function Coded_Exception (X : Natural) return 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 Natural is
+ begin
+ return T.Code;
+ end Get_Key;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Natural) return HTable_Headers is
+ begin
+ return HTable_Headers
+ (F mod Natural (HTable_Headers'Last - HTable_Headers'First + 1) + 1);
+ end Hash;
+
+ ----------------------------
+ -- Register_VMS_Exception --
+ ----------------------------
+
+ procedure Register_VMS_Exception (Code : Integer) is
+ -- Mask off lower 3 bits which are the severity
+
+ Excode : Integer := (Code / 8) * 8;
+ begin
+
+ -- This allocates an empty exception that gets filled in by
+ -- __gnat_error_handler when the exception is raised. Allocating
+ -- it here prevents having to allocate it each time the exception
+ -- is raised.
+
+ if Exception_Code_HTable.Get (Excode) = null then
+ Exception_Code_HTable.Set
+ (new Exception_Code_Data'
+ (Excode,
+ new Exception_Data'(False, 'V', 0, null, null, 0),
+ 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 00000000000..4d4b49babdd
--- /dev/null
+++ b/gcc/ada/s-vmexta.ads
@@ -0,0 +1,55 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1997 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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
+
+ procedure Register_VMS_Exception (Code : Integer);
+ -- Register an exception in the hash table mapping with a VMS
+ -- condition code.
+
+ -- LOTS more comments needed here regarding the enire scheme ???
+
+private
+
+ function Coded_Exception (X : Natural)
+ return System.Standard_Library.Exception_Data_Ptr;
+ -- Given a VMS condition, find and return it's allocated Ada exception
+ -- (called only from a-init.c).
+
+end System.VMS_Exception_Table;
diff --git a/gcc/ada/s-wchcnv.adb b/gcc/ada/s-wchcnv.adb
new file mode 100644
index 00000000000..f15b3440077
--- /dev/null
+++ b/gcc/ada/s-wchcnv.adb
@@ -0,0 +1,305 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ C N V --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains generic subprograms used for converting between
+-- sequences of Character and Wide_Character. All access to wide character
+-- sequences is isolated in this 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_Wide_Char --
+ --------------------------------
+
+ function Char_Sequence_To_Wide_Char
+ (C : Character;
+ EM : WC_Encoding_Method)
+ return Wide_Character
+ is
+ B1 : Integer;
+ C1 : Character;
+ U : Unsigned_16;
+ W : Unsigned_16;
+
+ 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.
+
+ -------------
+ -- Get_Hex --
+ -------------
+
+ procedure Get_Hex (N : Character) is
+ B2 : constant Integer := 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;
+
+ -- Start of processing for Char_Sequence_To_Wide_Char
+
+ begin
+ case EM is
+
+ when WCEM_Hex =>
+ if C /= ASCII.ESC then
+ return Wide_Character'Val (Character'Pos (C));
+
+ else
+ B1 := 0;
+ Get_Hex (In_Char);
+ Get_Hex (In_Char);
+ Get_Hex (In_Char);
+ Get_Hex (In_Char);
+
+ return Wide_Character'Val (B1);
+ end if;
+
+ when WCEM_Upper =>
+ if C > ASCII.DEL then
+ return
+ Wide_Character'Val
+ (Integer (256 * Character'Pos (C)) +
+ Character'Pos (In_Char));
+ else
+ return Wide_Character'Val (Character'Pos (C));
+ end if;
+
+ when WCEM_Shift_JIS =>
+ if C > ASCII.DEL then
+ return Shift_JIS_To_JIS (C, In_Char);
+ else
+ return Wide_Character'Val (Character'Pos (C));
+ end if;
+
+ when WCEM_EUC =>
+ if C > ASCII.DEL then
+ return EUC_To_JIS (C, In_Char);
+ else
+ return Wide_Character'Val (Character'Pos (C));
+ end if;
+
+ when WCEM_UTF8 =>
+ if C > ASCII.DEL then
+
+ -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
+ -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
+
+ U := Unsigned_16 (Character'Pos (C));
+
+ if (U and 2#11100000#) = 2#11000000# then
+ W := Shift_Left (U and 2#00011111#, 6);
+ U := Unsigned_16 (Character'Pos (In_Char));
+
+ if (U and 2#11000000#) /= 2#10000000# then
+ raise Constraint_Error;
+ end if;
+
+ W := W or (U and 2#00111111#);
+
+ elsif (U and 2#11110000#) = 2#11100000# then
+ W := Shift_Left (U and 2#00001111#, 12);
+ U := Unsigned_16 (Character'Pos (In_Char));
+
+ if (U and 2#11000000#) /= 2#10000000# then
+ raise Constraint_Error;
+ end if;
+
+ W := W or Shift_Left (U and 2#00111111#, 6);
+ U := Unsigned_16 (Character'Pos (In_Char));
+
+ if (U and 2#11000000#) /= 2#10000000# then
+ raise Constraint_Error;
+ end if;
+
+ W := W or (U and 2#00111111#);
+
+ else
+ raise Constraint_Error;
+ end if;
+
+ return Wide_Character'Val (W);
+
+ else
+ return Wide_Character'Val (Character'Pos (C));
+ end if;
+
+ when WCEM_Brackets =>
+
+ if C /= '[' then
+ return Wide_Character'Val (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
+ raise Constraint_Error;
+ end if;
+ end if;
+
+ if In_Char /= ']' then
+ raise Constraint_Error;
+ end if;
+
+ return Wide_Character'Val (B1);
+
+ end case;
+ end Char_Sequence_To_Wide_Char;
+
+ --------------------------------
+ -- Wide_Char_To_Char_Sequence --
+ --------------------------------
+
+ procedure Wide_Char_To_Char_Sequence
+ (WC : Wide_Character;
+ EM : WC_Encoding_Method)
+ is
+ Val : constant Natural := Wide_Character'Pos (WC);
+ Hexc : constant array (0 .. 15) of Character := "0123456789ABCDEF";
+ C1, C2 : Character;
+ U : Unsigned_16;
+
+ begin
+ case EM is
+
+ when WCEM_Hex =>
+ if Val < 256 then
+ Out_Char (Character'Val (Val));
+
+ else
+ 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));
+ end if;
+
+ when WCEM_Upper =>
+ if Val < 128 then
+ Out_Char (Character'Val (Val));
+
+ elsif Val < 16#8000# 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));
+ else
+ JIS_To_Shift_JIS (WC, C1, C2);
+ Out_Char (C1);
+ Out_Char (C2);
+ end if;
+
+ when WCEM_EUC =>
+ if Val < 128 then
+ Out_Char (Character'Val (Val));
+ else
+ JIS_To_EUC (WC, C1, C2);
+ Out_Char (C1);
+ Out_Char (C2);
+ end if;
+
+ when WCEM_UTF8 =>
+ U := Unsigned_16 (Val);
+
+ -- 16#0000#-16#007f#: 2#0xxxxxxx#
+ -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
+ -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
+
+ if U < 16#80# then
+ Out_Char (Character'Val (U));
+
+ elsif U < 16#0800# then
+ Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6)));
+ Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
+
+ else
+ 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#)));
+ end if;
+
+ when WCEM_Brackets =>
+
+ if Val < 256 then
+ Out_Char (Character'Val (Val));
+
+ else
+ Out_Char ('[');
+ Out_Char ('"');
+ 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));
+ Out_Char ('"');
+ Out_Char (']');
+ end if;
+ end case;
+ 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 00000000000..e42a0645bda
--- /dev/null
+++ b/gcc/ada/s-wchcnv.ads
@@ -0,0 +1,68 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ C N V --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains generic subprograms used for converting between
+-- sequences of Character and Wide_Character. All access to wide character
+-- sequences is isolated in this unit.
+
+with System.WCh_Con;
+
+package System.WCh_Cnv is
+pragma Pure (WCh_Cnv);
+
+ 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.
+
+ 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.
+
+end System.WCh_Cnv;
diff --git a/gcc/ada/s-wchcon.ads b/gcc/ada/s-wchcon.ads
new file mode 100644
index 00000000000..11f6688cbe2
--- /dev/null
+++ b/gcc/ada/s-wchcon.ads
@@ -0,0 +1,176 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ C O N --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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)
+
+package System.WCh_Con is
+pragma Pure (WCh_Con);
+
+ -------------------------------------
+ -- Wide_Character Encoding Methods --
+ -------------------------------------
+
+ -- A wide character encoding method is a method for uniquely representing
+ -- a 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"] where xx are hexadecimal
+ -- characters.
+
+ -- 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
+
+ -- 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 BMP. This is the default 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.
+
+ 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.
+
+ 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.
+
+ 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, 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 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 illegal UTF-8 sequences.)
+
+ WCEM_Brackets : constant WC_Encoding_Method := 6;
+ -- A wide character is represented as the sequence ["abcd"] where abcd
+ -- are four hexadecimal characters. In this mode, the sequence ["ab"]
+ -- is also recognized for the case of character codes in the range 0-255.
+
+ 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 := 8;
+ -- The longest number of characters that can be used for a wide
+ -- character sequence for any of the active encoding methods.
+
+end System.WCh_Con;
diff --git a/gcc/ada/s-wchjis.adb b/gcc/ada/s-wchjis.adb
new file mode 100644
index 00000000000..e9f9eaad6cd
--- /dev/null
+++ b/gcc/ada/s-wchjis.adb
@@ -0,0 +1,173 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ J I S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : in 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
+ if JIS1 = 0 then
+ EUC1 := Character'Val (EUC_Hankaku_Kana);
+ EUC2 := Character'Val (JIS2);
+
+ 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 : in 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 00000000000..d226b07d223
--- /dev/null
+++ b/gcc/ada/s-wchjis.ads
@@ -0,0 +1,80 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ J I S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines used for converting between internal
+-- JIS codes and the two external forms we support (EUC and Shift-JIS)
+
+package System.WCh_JIS is
+pragma Pure (WCh_JIS);
+
+ 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 : in 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 : in 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 00000000000..ad9d095e688
--- /dev/null
+++ b/gcc/ada/s-wchstw.adb
@@ -0,0 +1,221 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ S T W --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.14 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces; use Interfaces;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_JIS; use System.WCh_JIS;
+
+package body System.WCh_StW is
+
+ ---------------------------
+ -- String_To_Wide_String --
+ ---------------------------
+
+ function String_To_Wide_String
+ (S : String;
+ EM : WC_Encoding_Method)
+ return Wide_String
+ is
+ R : Wide_String (1 .. S'Length);
+ RP : Natural;
+ SP : Natural;
+ U1 : Unsigned_16;
+ U2 : Unsigned_16;
+ U3 : Unsigned_16;
+ U : Unsigned_16;
+
+ Last : constant Natural := S'Last;
+
+ function Get_Hex (C : Character) return Unsigned_16;
+ -- Converts character from hex digit to value in range 0-15. The
+ -- input must be in 0-9, A-F, or a-f, and no check is needed.
+
+ procedure Get_Hex_4;
+ -- Translates four hex characters starting at S (SP) to a single
+ -- wide character. Used in WCEM_Hex and WCEM_Brackets mode. SP
+ -- is not modified by the call. The resulting wide character value
+ -- is stored in R (RP). RP is not modified by the call.
+
+ function Get_Hex (C : Character) return Unsigned_16 is
+ begin
+ if C in '0' .. '9' then
+ return Character'Pos (C) - Character'Pos ('0');
+ elsif C in 'A' .. 'F' then
+ return Character'Pos (C) - Character'Pos ('A') + 10;
+ else
+ return Character'Pos (C) - Character'Pos ('a') + 10;
+ end if;
+ end Get_Hex;
+
+ procedure Get_Hex_4 is
+ begin
+ R (RP) := Wide_Character'Val (
+ Get_Hex (S (SP + 3)) + 16 *
+ (Get_Hex (S (SP + 2)) + 16 *
+ (Get_Hex (S (SP + 1)) + 16 *
+ (Get_Hex (S (SP + 0))))));
+ end Get_Hex_4;
+
+ -- Start of processing for String_To_Wide_String
+
+ begin
+ SP := S'First;
+ RP := 0;
+
+ case EM is
+
+ -- ESC-Hex representation
+
+ when WCEM_Hex =>
+ while SP <= Last - 4 loop
+ RP := RP + 1;
+
+ if S (SP) = ASCII.ESC then
+ SP := SP + 1;
+ Get_Hex_4;
+ SP := SP + 4;
+ else
+ R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
+ SP := SP + 1;
+ end if;
+ end loop;
+
+ -- Upper bit shift, internal code = external code
+
+ when WCEM_Upper =>
+ while SP < Last loop
+ RP := RP + 1;
+
+ if S (SP) >= Character'Val (16#80#) then
+ U1 := Character'Pos (S (SP));
+ U2 := Character'Pos (S (SP + 1));
+ R (RP) := Wide_Character'Val (256 * U1 + U2);
+ SP := SP + 2;
+ else
+ R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
+ SP := SP + 1;
+ end if;
+ end loop;
+
+ -- Upper bit shift, shift-JIS
+
+ when WCEM_Shift_JIS =>
+ while SP < Last loop
+ RP := RP + 1;
+
+ if S (SP) >= Character'Val (16#80#) then
+ R (RP) := Shift_JIS_To_JIS (S (SP), S (SP + 1));
+ SP := SP + 2;
+ else
+ R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
+ SP := SP + 1;
+ end if;
+ end loop;
+
+ -- Upper bit shift, EUC
+
+ when WCEM_EUC =>
+ while SP < Last loop
+ RP := RP + 1;
+
+ if S (SP) >= Character'Val (16#80#) then
+ R (RP) := EUC_To_JIS (S (SP), S (SP + 1));
+ SP := SP + 2;
+ else
+ R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
+ SP := SP + 1;
+ end if;
+ end loop;
+
+ -- Upper bit shift, UTF-8
+
+ when WCEM_UTF8 =>
+ while SP < Last loop
+ RP := RP + 1;
+
+ if S (SP) >= Character'Val (16#80#) then
+ U1 := Character'Pos (S (SP));
+ U2 := Character'Pos (S (SP + 1));
+
+ U := Shift_Left (U1 and 2#00011111#, 6) +
+ (U2 and 2#00111111#);
+ SP := SP + 2;
+
+ if U1 >= 2#11100000# then
+ U3 := Character'Pos (S (SP));
+ U := Shift_Left (U, 6) + (U3 and 2#00111111#);
+ SP := SP + 1;
+ end if;
+
+ R (RP) := Wide_Character'Val (U);
+
+ else
+ R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
+ SP := SP + 1;
+ end if;
+ end loop;
+
+ -- Brackets representation
+
+ when WCEM_Brackets =>
+ while SP <= Last - 7 loop
+ RP := RP + 1;
+
+ if S (SP) = '['
+ and then S (SP + 1) = '"'
+ and then S (SP + 2) /= '"'
+ then
+ SP := SP + 2;
+ Get_Hex_4;
+ SP := SP + 6;
+
+ else
+ R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
+ SP := SP + 1;
+ end if;
+ end loop;
+
+ end case;
+
+ while SP <= Last loop
+ RP := RP + 1;
+ R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
+ SP := SP + 1;
+ end loop;
+
+ return R (1 .. RP);
+ end String_To_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 00000000000..ee4161d1a1c
--- /dev/null
+++ b/gcc/ada/s-wchstw.ads
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ S T W --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used to convert strings to wide
+-- strings for use by wide character attributes (value, image etc.)
+
+with System.WCh_Con;
+
+package System.WCh_StW is
+pragma Pure (WCh_StW);
+
+ function String_To_Wide_String
+ (S : String;
+ EM : System.WCh_Con.WC_Encoding_Method)
+ return Wide_String;
+ -- This routine simply takes its argument and converts it to wide string
+ -- format. In the context of the Wide_Image attribute, 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#.
+
+end System.WCh_StW;
diff --git a/gcc/ada/s-wchwts.adb b/gcc/ada/s-wchwts.adb
new file mode 100644
index 00000000000..471c8fdb409
--- /dev/null
+++ b/gcc/ada/s-wchwts.adb
@@ -0,0 +1,165 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ W T S --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.13 $ --
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces; use Interfaces;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_JIS; use System.WCh_JIS;
+
+package body System.WCh_WtS is
+
+ ---------------------------
+ -- Wide_String_To_String --
+ ---------------------------
+
+ function Wide_String_To_String
+ (S : Wide_String;
+ EM : WC_Encoding_Method)
+ return String
+ is
+ R : String (1 .. 5 * S'Length); -- worst case length!
+ RP : Natural;
+ C1 : Character;
+ C2 : Character;
+
+ begin
+ RP := 0;
+
+ for SP in S'Range loop
+ declare
+ C : constant Wide_Character := S (SP);
+ CV : constant Unsigned_16 := Wide_Character'Pos (C);
+ Hex : constant array (Unsigned_16 range 0 .. 15) of Character :=
+ "0123456789ABCDEF";
+
+ begin
+ if CV <= 127 then
+ RP := RP + 1;
+ R (RP) := Character'Val (CV);
+
+ else
+ case EM is
+
+ -- Hex ESC sequence encoding
+
+ when WCEM_Hex =>
+ if CV <= 16#FF# then
+ RP := RP + 1;
+ R (RP) := Character'Val (CV);
+
+ else
+ R (RP + 1) := ASCII.ESC;
+ R (RP + 2) := Hex (Shift_Right (CV, 12));
+ R (RP + 3) := Hex (Shift_Right (CV, 8) and 16#000F#);
+ R (RP + 4) := Hex (Shift_Right (CV, 4) and 16#000F#);
+ R (RP + 5) := Hex (CV and 16#000F#);
+ RP := RP + 5;
+ end if;
+
+ -- Upper bit shift (internal code = external code)
+
+ when WCEM_Upper =>
+ R (RP + 1) := Character'Val (Shift_Right (CV, 8));
+ R (RP + 2) := Character'Val (CV and 16#FF#);
+ RP := RP + 2;
+
+ -- Upper bit shift (EUC)
+
+ when WCEM_EUC =>
+ JIS_To_EUC (C, C1, C2);
+ R (RP + 1) := C1;
+ R (RP + 2) := C2;
+ RP := RP + 2;
+
+ -- Upper bit shift (Shift-JIS)
+
+ when WCEM_Shift_JIS =>
+ JIS_To_Shift_JIS (C, C1, C2);
+ R (RP + 1) := C1;
+ R (RP + 2) := C2;
+ RP := RP + 2;
+
+ -- Upper bit shift (UTF-8)
+
+ -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
+ -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
+
+ when WCEM_UTF8 =>
+ if CV < 16#0800# then
+ R (RP + 1) :=
+ Character'Val (2#11000000# or Shift_Right (CV, 6));
+ R (RP + 2) :=
+ Character'Val (2#10000000# or (CV and 2#00111111#));
+ RP := RP + 2;
+
+ else
+ R (RP + 1) :=
+ Character'Val (2#11100000# or Shift_Right (CV, 12));
+ R (RP + 2) :=
+ Character'Val (2#10000000# or
+ (Shift_Right (CV, 6) and
+ 2#00111111#));
+ R (RP + 3) :=
+ Character'Val (2#10000000# or (CV and 2#00111111#));
+ RP := RP + 3;
+ end if;
+
+ -- Brackets encoding
+
+ when WCEM_Brackets =>
+ if CV <= 16#FF# then
+ RP := RP + 1;
+ R (RP) := Character'Val (CV);
+
+ else
+ R (RP + 1) := '[';
+ R (RP + 2) := '"';
+ R (RP + 3) := Hex (Shift_Right (CV, 12));
+ R (RP + 4) := Hex (Shift_Right (CV, 8) and 16#000F#);
+ R (RP + 5) := Hex (Shift_Right (CV, 4) and 16#000F#);
+ R (RP + 6) := Hex (CV and 16#000F#);
+ R (RP + 7) := '"';
+ R (RP + 8) := ']';
+ RP := RP + 8;
+ end if;
+
+ end case;
+ end if;
+ end;
+ end loop;
+
+ return R (1 .. RP);
+ end 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 00000000000..4e5308a7472
--- /dev/null
+++ b/gcc/ada/s-wchwts.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W C H _ W T S --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.7 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used to convert wide strings to
+-- strings for use by wide character attributes (value, image etc.) and
+-- also by the numeric IO subpackages of Ada.Text_IO.Wide_Text_IO.
+
+with System.WCh_Con;
+
+package System.WCh_WtS is
+pragma Pure (WCh_WtS);
+
+ 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#.
+
+end System.WCh_WtS;
diff --git a/gcc/ada/s-widboo.adb b/gcc/ada/s-widboo.adb
new file mode 100644
index 00000000000..5829e998fdd
--- /dev/null
+++ b/gcc/ada/s-widboo.adb
@@ -0,0 +1,55 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ B O O L --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..cf283104c14
--- /dev/null
+++ b/gcc/ada/s-widboo.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ B O O L --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for Boolean'Width
+
+package System.Wid_Bool is
+pragma Pure (Wid_Bool);
+
+ 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 00000000000..c2cf6d57c78
--- /dev/null
+++ b/gcc/ada/s-widcha.adb
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : 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 00000000000..d3b58e74d94
--- /dev/null
+++ b/gcc/ada/s-widcha.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for Character'Width
+
+package System.Wid_Char is
+pragma Pure (Wid_Char);
+
+ 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 00000000000..80a255ebf46
--- /dev/null
+++ b/gcc/ada/s-widenu.adb
@@ -0,0 +1,133 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ E N U M --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.9 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with 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
+ 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 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
+ 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 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
+ 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 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 00000000000..eb48664eebc
--- /dev/null
+++ b/gcc/ada/s-widenu.ads
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ E N U M --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.6 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for Enumeration_Type'Width
+
+package System.Wid_Enum is
+pragma Pure (Wid_Enum);
+
+ 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 00000000000..6d96260f161
--- /dev/null
+++ b/gcc/ada/s-widlli.adb
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ L L I --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..37cef827f56
--- /dev/null
+++ b/gcc/ada/s-widlli.ads
@@ -0,0 +1,49 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ L L I --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Wid_LLI);
+
+ 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 00000000000..6b90031ff82
--- /dev/null
+++ b/gcc/ada/s-widllu.adb
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ L L U --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 00000000000..c42a9e2b21b
--- /dev/null
+++ b/gcc/ada/s-widllu.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ L L U --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.4 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 (Wid_LLU);
+
+ 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 00000000000..4c6b8ef6a34
--- /dev/null
+++ b/gcc/ada/s-widwch.adb
@@ -0,0 +1,102 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ W C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.10 $ --
+-- --
+-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.WCh_Con; use System.WCh_Con;
+
+package body System.Wid_WChar is
+
+ --------------------------
+ -- Width_Wide_Character --
+ --------------------------
+
+ function Width_Wide_Character
+ (Lo, Hi : Wide_Character;
+ EM : WC_Encoding_Method)
+ 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
+
+ if P > 16#FF# then
+
+ case EM is
+
+ when WCEM_Hex =>
+ return Natural'Max (W, 5);
+
+ when WCEM_Upper =>
+ return Natural'Max (W, 2);
+
+ when WCEM_Shift_JIS =>
+ return Natural'Max (W, 2);
+
+ when WCEM_EUC =>
+ return Natural'Max (W, 2);
+
+ when WCEM_UTF8 =>
+ if Hi > Wide_Character'Val (16#07FF#) then
+ return Natural'Max (W, 3);
+ else
+ return Natural'Max (W, 2);
+ end if;
+
+ when WCEM_Brackets =>
+ return Natural'Max (W, 8);
+
+ end case;
+
+ -- 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;
+
+end System.Wid_WChar;
diff --git a/gcc/ada/s-widwch.ads b/gcc/ada/s-widwch.ads
new file mode 100644
index 00000000000..59847bd4e2f
--- /dev/null
+++ b/gcc/ada/s-widwch.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W I D _ W C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.5 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for Wide_Character'Width
+
+with System.WCh_Con;
+
+package System.Wid_WChar is
+pragma Pure (Wid_WChar);
+
+ function Width_Wide_Character
+ (Lo, Hi : Wide_Character;
+ EM : System.WCh_Con.WC_Encoding_Method)
+ return Natural;
+ -- Compute 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.
+
+end System.Wid_WChar;
diff --git a/gcc/ada/s-wwdcha.adb b/gcc/ada/s-wwdcha.adb
new file mode 100644
index 00000000000..b426d6e482f
--- /dev/null
+++ b/gcc/ada/s-wwdcha.adb
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W W D _ C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+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 : Wide_String := Character'Wide_Image (C);
+
+ begin
+ W := Natural'Max (W, S'Length);
+ end;
+ end loop;
+
+ return W;
+ end 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 00000000000..cb8545d851d
--- /dev/null
+++ b/gcc/ada/s-wwdcha.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W W D _ C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for Character'Wide_Width
+
+package System.WWd_Char is
+pragma Pure (WWd_Char);
+
+ 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.
+
+end System.WWd_Char;
diff --git a/gcc/ada/s-wwdenu.adb b/gcc/ada/s-wwdenu.adb
new file mode 100644
index 00000000000..8e43b1343eb
--- /dev/null
+++ b/gcc/ada/s-wwdenu.adb
@@ -0,0 +1,163 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W W D _ E N U M --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with System.WCh_StW; use System.WCh_StW;
+with System.WCh_Con; use System.WCh_Con;
+
+with Unchecked_Conversion;
+
+package body System.WWd_Enum is
+
+ ------------------------------
+ -- 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 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
+ WS : constant Wide_String :=
+ String_To_Wide_String
+ (Names (Natural (IndexesT (J)) ..
+ Natural (IndexesT (J + 1)) - 1), EM);
+
+ begin
+ W := Natural'Max (W, WS'Length);
+ 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 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
+ WS : constant Wide_String :=
+ String_To_Wide_String
+ (Names (Natural (IndexesT (J)) ..
+ Natural (IndexesT (J + 1)) - 1), EM);
+
+ begin
+ W := Natural'Max (W, WS'Length);
+ 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 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
+ WS : constant Wide_String :=
+ String_To_Wide_String
+ (Names (Natural (IndexesT (J)) ..
+ Natural (IndexesT (J + 1)) - 1), EM);
+
+ begin
+ W := Natural'Max (W, WS'Length);
+ 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 00000000000..e8900796788
--- /dev/null
+++ b/gcc/ada/s-wwdenu.ads
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . W W D _ E N U M --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.8 $
+-- --
+-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for Enumeration_Type'Wide_Width
+
+with System.WCh_Con;
+
+package System.WWd_Enum is
+pragma Pure (WWd_Enum);
+
+ 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.
+
+end System.WWd_Enum;
diff --git a/gcc/ada/s-wwdwch.adb b/gcc/ada/s-wwdwch.adb
new file mode 100644
index 00000000000..216eb6c6575
--- /dev/null
+++ b/gcc/ada/s-wwdwch.adb
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W W D _ W C H A R --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.4 $
+-- --
+-- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Wwd_WChar is
+
+ -------------------------------
+ -- Wide_Width_Wide_Character --
+ -------------------------------
+
+ function Wide_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);
+
+ -- If we are in wide character range, the length is always 3
+ -- and we are done, since all remaining characters are the same.
+
+ if P > 255 then
+ return Natural'Max (W, 3);
+
+ -- If we are in character range then use length of character image
+ -- Is this right, what about wide char encodings of 80-FF???
+
+ else
+ declare
+ S : Wide_String := Character'Wide_Image (Character'Val (P));
+
+ begin
+ W := Natural'Max (W, S'Length);
+ end;
+ end if;
+ end loop;
+
+ return W;
+ end Wide_Width_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 00000000000..cf3b93a5597
--- /dev/null
+++ b/gcc/ada/s-wwdwch.ads
@@ -0,0 +1,48 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . W W D _ W C H A R --
+-- --
+-- S p e c --
+-- --
+-- $Revision: 1.3 $ --
+-- --
+-- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routine used for Wide_Character'Wide_Width
+
+package System.Wwd_WChar is
+pragma Pure (Wwd_WChar);
+
+ 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.
+
+end System.Wwd_WChar;