summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c9
diff options
context:
space:
mode:
authorupstream source tree <ports@midipix.org>2015-03-15 20:14:05 -0400
committerupstream source tree <ports@midipix.org>2015-03-15 20:14:05 -0400
commit554fd8c5195424bdbcabf5de30fdc183aba391bd (patch)
tree976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/c9
downloadcbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2
cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c9')
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c910001.a224
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c910002.a143
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c910003.a185
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c91004b.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c91004c.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c91006a.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c91007a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c92002a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c92003a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c92005a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c92005b.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c92006a.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c930001.a153
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93001a.ada296
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93002a.ada231
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93003a.ada351
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93004a.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93004b.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93004c.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93004d.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93004f.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005a.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005b.ada273
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005c.ada250
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005d.ada289
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005e.ada247
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005f.ada255
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005g.ada245
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93005h.ada250
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93006a.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93007a.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93008a.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c93008b.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940001.a212
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940002.a309
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940004.a416
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940005.a370
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940006.a223
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940007.a427
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940010.a269
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940011.a175
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940012.a174
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940013.a379
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940014.a177
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940015.a149
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940016.a211
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94001a.ada259
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94001b.ada268
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94001c.ada267
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94001e.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94001f.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94001g.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94002a.ada331
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94002b.ada208
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94002d.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94002e.ada207
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94002f.ada227
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94002g.ada350
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94004a.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94004b.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94004c.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94005a.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94005b.ada168
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94006a.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94007a.ada270
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94007b.ada224
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94008a.ada61
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94008b.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94008c.ada265
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94008d.ada235
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94010a.ada243
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94011a.ada268
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c94020a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940a03.a350
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95008a.ada426
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95009a.ada121
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95010a.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95011a.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95012a.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95021a.ada182
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95022a.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95022b.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95033a.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95033b.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95034a.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95034b.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95035a.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95040a.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95040b.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95040c.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95040d.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95041a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95065a.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95065b.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95065c.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95065d.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95065e.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95065f.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95066a.ada214
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95067a.ada302
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95071a.ada230
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95072a.ada197
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95072b.ada278
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95073a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95074c.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95076a.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95078a.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95080b.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95082g.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085a.ada279
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085b.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085c.ada245
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085d.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085e.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085f.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085g.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085h.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085i.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085j.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085k.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085l.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085m.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085n.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95085o.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95086a.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95086b.ada202
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95086c.ada250
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95086d.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95086e.ada282
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95086f.ada282
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95087a.ada412
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95087b.ada267
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95087c.ada299
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95087d.ada268
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95088a.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95089a.ada175
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95090a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95092a.ada193
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95093a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95095a.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95095b.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95095c.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95095d.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c95095e.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c951001.a192
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c951002.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c953001.a188
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c953002.a242
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c953003.a189
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954001.a273
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954010.a286
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954011.a384
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954012.a496
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954013.a521
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954014.a485
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954015.a549
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954016.a182
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954017.a184
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954018.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954019.a314
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954020.a422
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954021.a524
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954022.a351
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954023.a558
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954024.a380
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954025.a237
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954026.a269
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954a01.a262
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954a02.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954a03.a322
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c960001.a164
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c960002.a171
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c960004.a206
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96001a.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96004a.ada258
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96005a.ada239
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96005b.tst135
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96005d.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96005f.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96006a.ada298
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96007a.ada203
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96008a.ada203
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c96008b.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97112a.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97113a.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97114a.ada196
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97115a.ada189
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97116a.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97117a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97117b.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97117c.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97118a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97120a.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97120b.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201a.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201b.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201c.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201d.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201e.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201g.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201h.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97201x.ada170
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97202a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97203a.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97203b.ada131
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97203c.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97204a.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97204b.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97205a.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97205b.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97301a.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97301b.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97301c.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97301d.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97301e.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97302a.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97303a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97303b.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97303c.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97304a.ada123
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97304b.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97305a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97305b.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97305c.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97305d.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c97307a.ada209
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974001.a152
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974002.a209
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974003.a249
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974004.a273
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974005.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974006.a197
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974007.a205
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974008.a229
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974009.a206
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974010.a209
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974011.a275
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974012.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974013.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974014.a132
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c980001.a303
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c980002.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c980003.a294
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c99004a.ada166
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c99005a.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a003a.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a004a.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a007a.ada293
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a009a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a009c.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a009f.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a009g.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a009h.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a010a.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a011a.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c9a011b.ada102
256 files changed, 45302 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910001.a b/gcc/testsuite/ada/acats/tests/c9/c910001.a
new file mode 100644
index 000000000..416e13ca8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c910001.a
@@ -0,0 +1,224 @@
+-- C910001.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that tasks may have discriminants. Specifically, check where
+-- the subtype of the discriminant is a discrete subtype and where it is
+-- an access subtype. Check the case where the default values of the
+-- discriminants are used.
+--
+-- TEST DESCRIPTION:
+-- A task is defined with two discriminants, one a discrete subtype and
+-- another that is an access subtype. Tasks are created with various
+-- values for discriminants and code within the task checks that these
+-- are passed in correctly. One instance of a default is used. The
+-- values passed to the task as the discriminants are taken from an
+-- array of test data and the values received are checked against the
+-- same array.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+
+procedure C910001 is
+
+
+ type App_Priority is range 1..10;
+ Default_Priority : App_Priority := 5;
+
+ type Message_ID is range 1..10_000;
+
+ type TC_Number_of_Messages is range 1..5;
+
+ type TC_rec is record
+ TC_ID : Message_ID;
+ A_Priority : App_Priority;
+ TC_Checked : Boolean;
+ end record;
+
+ -- This table is used to create the messages and to check them
+ TC_table : array (1..TC_Number_of_Messages'Last) of TC_Rec :=
+ ( ( 10, 6, false ),
+ ( 20, 2, false ),
+ ( 30, 9, false ),
+ ( 40, 1, false ),
+ ( 50, Default_Priority, false ) );
+
+begin -- C910001
+
+ Report.Test ("C910001", "Check that tasks may have discriminants");
+
+
+ declare -- encapsulate the test
+
+ type Transaction_Record is
+ record
+ ID : Message_ID;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ end record;
+ --
+ type acc_Transaction_Record is access Transaction_Record;
+
+
+ task type Message_Task
+ (In_Message : acc_Transaction_Record := null;
+ In_Priority : App_Priority := Default_Priority) is
+ entry Start;
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+ --
+ --
+ task body Message_Task is
+ This_Message : acc_Transaction_Record := In_Message;
+ This_Priority : App_Priority := In_Priority;
+ TC_Match_Found : Boolean := false;
+ begin
+ accept Start;
+ -- In the example envisioned this task would then queue itself
+ -- upon some Distributor task which would send it off (requeue) to
+ -- the message processing tasks according to the priority of the
+ -- message and the current load on the system. For the test we
+ -- just verify the data passed in as discriminants and exit the task
+ --
+ -- Check for the special case of default discriminants
+ if This_Message = null then
+ -- The default In_Message has been passed, check that the
+ -- default priority was also passed
+ if This_Priority /= Default_Priority then
+ Report.Failed ("Incorrect Default Priority");
+ end if;
+ if TC_Table (TC_Number_of_Messages'Last).TC_Checked then
+ Report.Failed ("Duplicate Default messages");
+ else
+ -- Mark that default has been seen
+ TC_Table (TC_Number_of_Messages'Last).TC_Checked := True;
+ end if;
+ TC_Match_Found := true;
+ else
+ -- Check the data against the table
+ for i in TC_Number_of_Messages loop
+ if TC_Table(i).TC_ID = This_Message.ID then
+ -- this is the right slot in the table
+ if TC_Table(i).TC_checked then
+ -- Already checked
+ Report.Failed ("Duplicate Data");
+ else
+ TC_Table(i).TC_checked := true;
+ end if;
+ TC_Match_Found := true;
+ if TC_Table(i).A_Priority /= This_Priority then
+ Report.Failed ("ID/Priority mismatch");
+ end if;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if not TC_Match_Found then
+ Report.Failed ("No ID match in table");
+ end if;
+
+ -- Allow the task to terminate
+
+ end Message_Task;
+
+
+ -- The Line Driver task accepts data from an external source and
+ -- builds them into a transaction record. It then generates a
+ -- message task. This message "contains" the record and is given
+ -- a priority according to the contents of the message. The priority
+ -- and transaction records are passed to the task as discriminants.
+ -- In this test we use a dummy record. Only the ID is of interest
+ -- so we pick that and the required priority from an array of
+ -- test data. We artificially limit the endless driver-loop to
+ -- the number of messages required for the test and add a special
+ -- case to check the defaults.
+ --
+ task Driver_Task;
+ --
+ task body Driver_Task is
+ begin
+
+ -- Create all but one of the required tasks
+ --
+ for i in 1..TC_Number_of_Messages'Last - 1 loop
+ declare
+ -- Create a record for the next message
+ Next_Transaction : acc_Transaction_Record :=
+ new Transaction_Record;
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task :=
+ new Message_Task( Next_Transaction,
+ TC_Table(i).A_Priority );
+
+ begin
+ -- Artificially plug the ID with the next from the table
+ -- In reality the whole record would be built here
+ Next_Transaction.ID := TC_Table(i).TC_ID;
+
+ -- Ensure the task does not start executing till the
+ -- transaction record is properly constructed
+ Next_Message_Task.Start;
+
+ end; -- declare
+ end loop;
+
+ -- For this subtest create one task with the default discriminants
+ --
+ declare
+
+ -- Create the task
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+
+ begin
+
+ Next_Message_Task.Start;
+
+ end; -- declare
+
+
+ end Driver_Task;
+
+ begin
+ null;
+ end; -- encapsulation
+
+ -- Now verify that all the tasks executed and checked in
+ for i in TC_Number_of_Messages loop
+ if not TC_Table(i).TC_Checked then
+ Report.Failed
+ ("Task" & integer'image(integer (i) ) & " did not verify");
+ end if;
+ end loop;
+ Report.Result;
+
+end C910001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910002.a b/gcc/testsuite/ada/acats/tests/c9/c910002.a
new file mode 100644
index 000000000..dc0b9b36b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c910002.a
@@ -0,0 +1,143 @@
+-- C910002.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the contents of a task object include the values
+-- of its discriminants.
+-- Check that selected_component notation can be used to
+-- denote a discriminant of a task.
+--
+-- TEST DESCRIPTION:
+-- This test declares a task type that contains discriminants.
+-- Objects of the task type are created with different values.
+-- The task type has nested tasks that are used to check that
+-- the discriminate values are the expected values.
+-- Note that the names of the discriminants in the body of task
+-- type DTT denote the current instance of the unit.
+--
+--
+-- CHANGE HISTORY:
+-- 12 OCT 95 SAIC Initial release for 2.1
+-- 8 MAY 96 SAIC Incorporated Reviewer comments.
+--
+--!
+
+
+with Report;
+procedure C910002 is
+ Verbose : constant Boolean := False;
+begin
+ Report.Test ("C910002",
+ "Check that selected_component notation can be" &
+ " used to access task discriminants");
+ declare
+
+ task type DTT
+ (IA, IB : Integer;
+ CA, CB : Character) is
+ entry Check_Values (First_Int : Integer;
+ First_Char : Character);
+ end DTT;
+
+ task body DTT is
+ Int1 : Integer;
+ Char1 : Character;
+
+ -- simple nested task to check the character values
+ task Check_Chars is
+ entry Start_Check;
+ end Check_Chars;
+ task body Check_Chars is
+ begin
+ accept Start_Check;
+ if DTT.CA /= Char1 or
+ DTT.CB /= Character'Succ (Char1) then
+ Report.Failed ("character check failed. Expected: '" &
+ Char1 & Character'Succ (Char1) &
+ "' but found '" &
+ DTT.CA & DTT.CB & "'");
+ elsif Verbose then
+ Report.Comment ("char check for " & Char1);
+ end if;
+ exception
+ when others => Report.Failed ("exception in Check_Chars");
+ end Check_Chars;
+
+ -- use a discriminated task to check the integer values
+ task type Check_Ints (First : Integer);
+ task body Check_Ints is
+ begin
+ if DTT.IA /= Check_Ints.First or
+ IB /= First+1 then
+ Report.Failed ("integer check failed. Expected:" &
+ Integer'Image (Check_Ints.First) &
+ Integer'Image (First+1) &
+ " but found" &
+ Integer'Image (DTT.IA) & Integer'Image (IB) );
+ elsif Verbose then
+ Report.Comment ("int check for" & Integer'Image (First));
+ end if;
+ exception
+ when others => Report.Failed ("exception in Check_Ints");
+ end Check_Ints;
+ begin
+ accept Check_Values (First_Int : Integer;
+ First_Char : Character) do
+ Int1 := First_Int;
+ Char1 := First_Char;
+ end Check_Values;
+
+ -- kick off the character check
+ Check_Chars.Start_Check;
+
+ -- do the integer check
+ declare
+ Int_Checker : Check_Ints (Int1);
+ begin
+ null; -- let task do its thing
+ end;
+
+ -- do one test here too
+ if DTT.IA /= Int1 then
+ Report.Failed ("DTT check failed. Expected:" &
+ Integer'Image (Int1) &
+ " but found:" &
+ Integer'Image (DTT.IA));
+ elsif Verbose then
+ Report.Comment ("DTT check for" & Integer'Image (Int1));
+ end if;
+ exception
+ when others => Report.Failed ("exception in DTT");
+ end DTT;
+
+ T1a : DTT (1, 2, 'a', 'b');
+ T9C : DTT (9, 10, 'C', 'D');
+ begin -- test encapsulation
+ T1a.Check_Values (1, 'a');
+ T9C.Check_Values (9, 'C');
+ end;
+
+ Report.Result;
+end C910002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910003.a b/gcc/testsuite/ada/acats/tests/c9/c910003.a
new file mode 100644
index 000000000..b2e11cef8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c910003.a
@@ -0,0 +1,185 @@
+-- C910003.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
+-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
+-- software and documentation contained herein. Unlimited rights are
+-- defined in DFAR 252.227-7013(a)(19). By making this public release,
+-- the Government intends to confer upon all recipients unlimited rights
+-- equal to those held by the Government. These rights include rights to
+-- use, duplicate, release or disclose the released technical data and
+-- computer software in whole or in part, in any manner and for any purpose
+-- whatsoever, and to have or permit others to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that task discriminants that have an access subtype may be
+-- dereferenced.
+--
+-- Note that discriminants in Ada 83 never can be dereferenced with
+-- selection or indexing, as they cannot have an access type.
+--
+-- TEST DESCRIPTION:
+-- A protected object is defined to create a simple buffer.
+-- Two task types are defined, one to put values into the buffer,
+-- and one to remove them. The tasks are passed a buffer object as
+-- a discriminant with an access subtype. The producer task type includes
+-- a discriminant to determine the values to product. The consumer task
+-- type includes a value to save the results.
+-- Two producer and one consumer tasks are declared, and the results
+-- are checked.
+--
+-- CHANGE HISTORY:
+-- 10 Mar 99 RLB Created test.
+--
+--!
+
+package C910003_Pack is
+
+ type Item_Type is range 1 .. 100; -- In a real application, this probably
+ -- would be a record type.
+
+ type Item_Array is array (Positive range <>) of Item_Type;
+
+ protected type Buffer is
+ entry Put (Item : in Item_Type);
+ entry Get (Item : out Item_Type);
+ function TC_Items_Buffered return Item_Array;
+ private
+ Saved_Item : Item_Type;
+ Empty : Boolean := True;
+ TC_Items : Item_Array (1 .. 10);
+ TC_Last : Natural := 0;
+ end Buffer;
+
+ type Buffer_Access_Type is access Buffer;
+
+ PRODUCE_COUNT : constant := 2; -- Number of items to produce.
+
+ task type Producer (Buffer_Access : Buffer_Access_Type;
+ Start_At : Item_Type);
+ -- Produces PRODUCE_COUNT items. Starts when activated.
+
+ type TC_Item_Array_Access_Type is access Item_Array (1 .. PRODUCE_COUNT*2);
+
+ task type Consumer (Buffer_Access : Buffer_Access_Type;
+ Results : TC_Item_Array_Access_Type) is
+ -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
+ -- activated.
+ entry Wait_until_Done;
+ end Consumer;
+
+end C910003_Pack;
+
+
+with Report;
+package body C910003_Pack is
+
+ protected body Buffer is
+ entry Put (Item : in Item_Type) when Empty is
+ begin
+ Empty := False;
+ Saved_Item := Item;
+ TC_Last := TC_Last + 1;
+ TC_Items(TC_Last) := Item;
+ end Put;
+
+ entry Get (Item : out Item_Type) when not Empty is
+ begin
+ Empty := True;
+ Item := Saved_Item;
+ end Get;
+
+ function TC_Items_Buffered return Item_Array is
+ begin
+ return TC_Items(1..TC_Last);
+ end TC_Items_Buffered;
+
+ end Buffer;
+
+
+ task body Producer is
+ -- Produces PRODUCE_COUNT items. Starts when activated.
+ begin
+ for I in 1 .. Report.Ident_Int(PRODUCE_COUNT) loop
+ Buffer_Access.Put (Start_At + (Item_Type(I)-1)*2);
+ end loop;
+ end Producer;
+
+
+ task body Consumer is
+ -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
+ -- activated.
+ begin
+ for I in 1 .. Report.Ident_Int(PRODUCE_COUNT*2) loop
+ Buffer_Access.Get (Results (I));
+ -- Buffer_Access and Results are both dereferenced.
+ end loop;
+
+ -- Check the results (and function call with a prefix dereference).
+ if Results.all(Report.Ident_Int(1)) /= Buffer_Access.all.TC_Items_Buffered(Report.Ident_Int(1)) then
+ Report.Failed ("First item mismatch");
+ end if;
+ if Results(Report.Ident_Int(2)) /= Buffer_Access.TC_Items_Buffered(Report.Ident_Int(2)) then
+ Report.Failed ("Second item mismatch");
+ end if;
+ accept Wait_until_Done; -- Tell main that we're done.
+ end Consumer;
+
+end C910003_Pack;
+
+
+with Report;
+with C910003_Pack;
+
+procedure C910003 is
+
+begin -- C910003
+
+ Report.Test ("C910003", "Check that tasks discriminants of access types can be dereferenced");
+
+
+ declare -- encapsulate the test
+
+ Buffer_Access : C910003_Pack.Buffer_Access_Type :=
+ new C910003_Pack.Buffer;
+
+ TC_Results : C910003_Pack.TC_Item_Array_Access_Type :=
+ new C910003_Pack.Item_Array (1 .. C910003_Pack.PRODUCE_COUNT*2);
+
+ Producer_1 : C910003_Pack.Producer (Buffer_Access, 12);
+ Producer_2 : C910003_Pack.Producer (Buffer_Access, 23);
+
+ Consumer : C910003_Pack.Consumer (Buffer_Access, TC_Results);
+
+ use type C910003_Pack.Item_Array; -- For /=.
+
+ begin
+ Consumer.Wait_until_Done;
+ if TC_Results.all /= Buffer_Access.TC_Items_Buffered then
+ Report.Failed ("Different items buffered than returned - Main");
+ end if;
+ if (TC_Results.all /= (12, 14, 23, 25) and
+ TC_Results.all /= (12, 23, 14, 25) and
+ TC_Results.all /= (12, 23, 25, 14) and
+ TC_Results.all /= (23, 12, 14, 25) and
+ TC_Results.all /= (23, 12, 25, 14) and
+ TC_Results.all /= (23, 25, 12, 14)) then
+ -- Above are the only legal results.
+ Report.Failed ("Wrong results");
+ end if;
+ end; -- encapsulation
+
+ Report.Result;
+
+end C910003;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c91004b.ada b/gcc/testsuite/ada/acats/tests/c9/c91004b.ada
new file mode 100644
index 000000000..16a17cf32
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c91004b.ada
@@ -0,0 +1,108 @@
+-- C91004B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT A TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN
+-- BODY, REFERS TO THE EXECUTING TASK.
+
+-- TEST USING IDENTIFIER IN ABORT STATEMENT, AS AN EXPRESSION IN
+-- A MEMBERSHIP TEST, AND THE PREFIX OF 'CALLABLE AND
+-- 'TERMINATED.
+
+-- HISTORY:
+-- WEI 3/ 4/82 CREATED ORIGINAL TEST.
+-- RJW 11/13/87 RENAMED TEST FROM C910BDA.ADA. ADDED CHECKS FOR
+-- MEMBERSHIP TEST, AND 'CALLABLE AND 'TERMINATED
+-- ATTRIBUTES.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C91004B IS
+
+ TYPE I0 IS RANGE 0..1;
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ TASK TYPE TT1 IS
+ ENTRY E1 (P1 : IN I0; P2 : ARG);
+ ENTRY BYE;
+ END TT1;
+
+ SUBTYPE SUB_TT1 IS TT1;
+
+ OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+ TASK BODY TT1 IS
+ BEGIN
+ IF TT1 NOT IN SUB_TT1 THEN
+ FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST");
+ END IF;
+
+ IF NOT TT1'CALLABLE THEN
+ FAILED ("INCORRECT RESULTS FOR 'CALLABLE");
+ END IF;
+
+ IF TT1'TERMINATED THEN
+ FAILED ("INCORRECT RESULTS FOR 'TERMINATED");
+ END IF;
+
+ ACCEPT E1 (P1 : IN I0; P2 : ARG) DO
+ IF P1 = 1 THEN
+ ABORT TT1;
+ ACCEPT BYE; -- WILL DEADLOCK IF NOT ABORTED.
+ END IF;
+ PSPY_NUMB (ARG (P2));
+ END E1;
+
+ END TT1;
+
+BEGIN
+
+ TEST ("C91004B", "TASK IDENTIFIER IN OWN BODY");
+
+ BEGIN
+ OBJ_TT1 (1).E1 (1,1);
+ FAILED ("NO TASKING_ERROR RAISED");
+-- ABORT DURING RENDEVOUS RAISES TASKING ERROR
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION RAISED");
+ END;
+
+ OBJ_TT1 (2).E1 (0,2);
+
+ IF SPYNUMB /= 2 THEN
+ FAILED ("WRONG TASK OBJECT REFERENCED");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C91004B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c91004c.ada b/gcc/testsuite/ada/acats/tests/c9/c91004c.ada
new file mode 100644
index 000000000..a07543370
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c91004c.ada
@@ -0,0 +1,82 @@
+-- C91004C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN BODY
+-- REFERS TO THE EXECUTING TASK.
+--
+-- TEST USING CONDITIONAL ENTRY CALL.
+
+-- WEI 3/ 4/82
+-- TLB 10/30/87 RENAMED FROM C910BDB.ADA.
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C91004C IS
+
+ TASK TYPE TT1 IS
+ ENTRY E1;
+ ENTRY BYE;
+ END TT1;
+
+ OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1;
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+ TASK BODY TT1 IS
+ BEGIN
+ ACCEPT E1 DO
+ PSPY_NUMB (1);
+ END E1;
+
+ SELECT
+ TT1.E1;
+ ELSE
+ PSPY_NUMB (2);
+ END SELECT;
+
+ ACCEPT BYE;
+ END TT1;
+
+BEGIN
+
+ TEST ("C91004C", "TASK IDENTIFIER IN OWN BODY");
+ OBJ_TT1 (1).E1;
+ OBJ_TT1 (1).BYE;
+
+ IF SPYNUMB /=12 THEN
+ FAILED ("WRONG TASK OBJECT REFERENCED");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ ABORT OBJ_TT1 (2);
+
+ RESULT;
+
+END C91004C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c91006a.ada b/gcc/testsuite/ada/acats/tests/c9/c91006a.ada
new file mode 100644
index 000000000..1217d1459
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c91006a.ada
@@ -0,0 +1,82 @@
+-- C91006A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IN A TASK SPECIFICATION ENTRY DECLARATIONS ARE ELABORATED
+-- WHEN THE SPECIFICATION IS ELABORATED, AND IN TEXTUAL ORDER.
+
+-- WEI 3/04/82
+-- BHS 7/13/84
+-- TBN 12/17/85 RENAMED FROM C910AHA-B.ADA;
+-- ADDED DECLARATIONS OF FIRST AND LAST.
+-- PWB 5/15/86 MOVED DECLARATIONS OF FIRST, TASK T1, AND LAST
+-- INTO A DECLARE/BEGIN/END BLOCK.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C91006A IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ INDEX : INTEGER RANGE 0..5 := 0;
+ SPYNUMB : STRING(1..5) := (1..5 => ' ');
+
+ FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS
+ TEMP : STRING(1..2);
+ BEGIN
+ TEMP := ARG'IMAGE(DIGT);
+ INDEX := INDEX + 1;
+ SPYNUMB(INDEX) := TEMP(2);
+ RETURN DIGT;
+ END FINIT_POS;
+
+BEGIN
+ TEST ("C91006A", "CHECK THAT IN A TASK SPEC, ELABORATION IS IN " &
+ "TEXTUAL ORDER");
+ DECLARE
+
+ FIRST : INTEGER := FINIT_POS (1);
+
+ TASK T1 IS
+ ENTRY E2 (NATURAL RANGE 1 .. FINIT_POS (2));
+ ENTRY E3 (NATURAL RANGE 1 .. FINIT_POS (3));
+ ENTRY E4 (NATURAL RANGE 1 .. FINIT_POS (4));
+ END T1;
+
+ LAST : INTEGER := FINIT_POS (5);
+
+ TASK BODY T1 IS
+ BEGIN
+ NULL;
+ END T1;
+
+ BEGIN
+ NULL;
+ END;
+
+ IF SPYNUMB /= "12345" THEN
+ FAILED ("TASK SPEC T1 NOT ELABORATED IN TEXTUAL ORDER");
+ COMMENT ("ACTUAL ORDER WAS: " & SPYNUMB);
+ END IF;
+
+ RESULT;
+
+END C91006A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c91007a.ada b/gcc/testsuite/ada/acats/tests/c9/c91007a.ada
new file mode 100644
index 000000000..d2b21b302
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c91007a.ada
@@ -0,0 +1,97 @@
+-- C91007A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- IF THE ELABORATION OF AN ENTRY DECLARATION RAISES
+-- "CONSTRAINT_ERROR", THEN NO TASKS ARE ACTIVATED, AND
+-- "TASKING_ERROR" IS NOT RAISED.
+
+-- HISTORY:
+-- LDC 06/17/88 CREATED ORGINAL TEST
+
+WITH REPORT;
+USE REPORT;
+
+PROCEDURE C91007A IS
+
+ TYPE ENUM IS (TERESA, BRIAN, PHIL, JOLEEN, LYNN, DOUG, JODIE,
+ VINCE, TOM, DAVE, JOHN, ROSA);
+ SUBTYPE ENUM_SUB IS ENUM RANGE BRIAN..LYNN;
+
+BEGIN
+ TEST("C91007A","IF THE ELABORATION OF AN ENTRY DECLARATION " &
+ "RAISES 'CONSTRAINT_ERROR', THEN NO TASKS ARE " &
+ "ACTIVATED, AND 'TASKING_ERROR' IS NOT RAISED");
+
+ BEGIN
+ DECLARE
+ TASK TYPE TSK1;
+ T1 : TSK1;
+ TASK BODY TSK1 IS
+ BEGIN
+ FAILED("TSK1 WAS ACTIVATED");
+ END TSK1;
+
+
+ TASK TSK2 IS
+ ENTRY ENT(ENUM_SUB RANGE TERESA..LYNN);
+ END TSK2;
+
+ TASK BODY TSK2 IS
+ BEGIN
+ FAILED("TASK BODY WAS ACTIVATED");
+ END TSK2;
+
+ TASK TSK3;
+ TASK BODY TSK3 IS
+ BEGIN
+ FAILED("TSK3 WAS ACTIVATED");
+ END TSK3;
+
+ BEGIN
+ NULL;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED("CONSTRAINT_ERROR WAS RAISED IN THE " &
+ "BEGIN BLOCK");
+ WHEN TASKING_ERROR =>
+ FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " &
+ "CONSTRAINT_ERROR IN THE BEGIN BLOCK");
+ WHEN OTHERS =>
+ FAILED("OTHER EXCEPTION WAS RAISED IN " &
+ "THE BEGIN BLOCK");
+ END;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TASKING_ERROR =>
+ FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " &
+ "CONSTRAINT_ERROR");
+ WHEN OTHERS =>
+ FAILED("WRONG EXCEPTION WAS RAISED");
+ END;
+
+ RESULT;
+
+END C91007A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c92002a.ada b/gcc/testsuite/ada/acats/tests/c9/c92002a.ada
new file mode 100644
index 000000000..879cf36b9
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c92002a.ada
@@ -0,0 +1,73 @@
+-- C92002A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ASSIGNMENT TO A COMPONENT (FOR WHICH ASSIGNMENT IS
+-- AVAILABLE) OF A RECORD CONTAINING A TASK IS AVAILABLE.
+
+-- JRK 9/17/81
+-- JWC 6/28/85 RENAMED TO -AB
+
+WITH REPORT; USE REPORT;
+PROCEDURE C92002A IS
+
+BEGIN
+ TEST ("C92002A", "CHECK THAT CAN ASSIGN TO ASSIGNABLE " &
+ "COMPONENTS OF RECORDS WITH TASK " &
+ "COMPONENTS");
+
+ DECLARE
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TYPE RT IS
+ RECORD
+ I : INTEGER := 0;
+ T : TT;
+ J : INTEGER := 0;
+ END RECORD;
+
+ R : RT;
+
+ TASK BODY TT IS
+ BEGIN
+ NULL;
+ END TT;
+
+ BEGIN
+
+ R.I := IDENT_INT (7);
+ R.J := IDENT_INT (9);
+
+ IF R.I /= 7 AND R.J /= 9 THEN
+ FAILED ("WRONG VALUE(S) WHEN ASSIGNING TO " &
+ "INTEGER COMPONENTS OF RECORDS WITH " &
+ "TASK COMPONENTS");
+ END IF;
+
+ END;
+
+ RESULT;
+END C92002A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c92003a.ada b/gcc/testsuite/ada/acats/tests/c9/c92003a.ada
new file mode 100644
index 000000000..ff42680b0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c92003a.ada
@@ -0,0 +1,117 @@
+-- C92003A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK CAN BE PASSED AS AN ACTUAL IN OR IN OUT PARAMETER
+-- IN A SUBPROGRAM CALL AND THAT THE ACTUAL AND FORMAL PARAMETERS DENOTE
+-- THE SAME TASK OBJECT.
+
+-- JRK 1/17/81
+-- TBN 12/19/85 ADDED IN OUT PARAMETER CASE.
+-- PWB 8/04/86 ADDED CHECK THAT FORMAL AND ACTUAL PARAMETERS DENOTE
+-- THE SAME TASK OBJECT.
+
+WITH REPORT; USE REPORT;
+
+PROCEDURE C92003A IS
+
+BEGIN
+
+ TEST ("C92003A", "CHECK TASKS PASSED AS ACTUAL IN OR IN OUT " &
+ "PARAMETERS TO SUBPROGRAMS");
+
+ DECLARE
+
+ TASK TYPE TT IS
+ ENTRY E (I : INTEGER);
+ END TT;
+
+ T, S : TT;
+
+ TASK BODY TT IS
+ SOURCE : INTEGER;
+ BEGIN
+
+ SELECT
+ ACCEPT E (I : INTEGER) DO
+ SOURCE := I;
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+
+ IF SOURCE /= 1 THEN
+ FAILED ("EXPECTED 1, GOT " & INTEGER'IMAGE(SOURCE));
+ END IF;
+
+ SELECT
+ ACCEPT E (I : INTEGER) DO
+ SOURCE := I;
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+
+ IF SOURCE /= 2 THEN
+ FAILED ("EXPECTED 2, GOT " & INTEGER'IMAGE(SOURCE));
+ END IF;
+
+ SELECT
+ ACCEPT E (I : INTEGER) DO
+ SOURCE := I;
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+
+ IF SOURCE /= 3 THEN
+ FAILED ("EXPECTED 3, GOT " & INTEGER'IMAGE(SOURCE));
+ END IF;
+
+ END TT;
+
+ PROCEDURE P (T : TT) IS
+ BEGIN
+ T.E(2);
+ END P;
+
+ PROCEDURE Q (S : IN OUT TT) IS
+ BEGIN
+ S.E(2);
+ END Q;
+
+ BEGIN
+
+ T.E(1); -- FIRST CALL TO T.E
+ P(T); -- SECOND CALL TO T.E
+ T.E(3); -- THIRD CALL TO T.E
+
+ S.E(1); -- FIRST CALL TO S.E
+ Q(S); -- SECOND CALL TO S.E
+ S.E(3); -- THIRD CALL TO S.E
+
+ END;
+
+ RESULT;
+
+END C92003A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c92005a.ada b/gcc/testsuite/ada/acats/tests/c9/c92005a.ada
new file mode 100644
index 000000000..6766c573e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c92005a.ada
@@ -0,0 +1,75 @@
+-- C92005A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT FOR A NON-SINGLE TASK THE OBJECT VALUE IS SET DURING
+-- ELABORATION OF THE CORRESPONDING OBJECT DECLARATION.
+
+-- WEI 3/ 4/82
+-- JBG 5/25/85
+-- PWB 2/3/86 CORRECTED TEST ERROR; ADDED 'USE' CLAUSE TO MAKE "/="
+-- FOR BIG_INT VISIBLE.
+
+WITH REPORT, SYSTEM;
+ USE REPORT;
+PROCEDURE C92005A IS
+BEGIN
+
+ TEST ("C92005A", "TASK OBJECT VALUE DURING ELABORATION");
+
+ DECLARE
+ TASK TYPE TT1;
+
+ OBJ_TT1 : TT1;
+
+ PACKAGE PACK IS
+ TYPE BIG_INT IS RANGE 0 .. SYSTEM.MAX_INT;
+ I : BIG_INT;
+ END PACK;
+
+ PACKAGE BODY PACK IS
+ BEGIN
+ I := OBJ_TT1'STORAGE_SIZE; -- O.K.
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("TASK OBJECT RAISED EXCEPTION");
+ END PACK;
+
+ USE PACK;
+
+ TASK BODY TT1 IS
+ BEGIN
+ NULL;
+ END TT1;
+
+ BEGIN
+ IF PACK.I /= OBJ_TT1'STORAGE_SIZE THEN
+ COMMENT ("STORAGE SIZE CHANGED AFTER TASK ACTIVATED");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED BY STORAGE_SIZE");
+ END;
+
+ RESULT;
+END C92005A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c92005b.ada b/gcc/testsuite/ada/acats/tests/c9/c92005b.ada
new file mode 100644
index 000000000..e5672a7c7
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c92005b.ada
@@ -0,0 +1,72 @@
+-- C92005B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT FOR A TASK OBJECT CREATED BY AN ALLOCATOR THE
+-- OBJECT VALUE IS SET DURING EXECUTION OF THE ALLOCATOR.
+
+-- WEI 3/ 4/82
+-- JBG 5/25/85
+-- RLB 1/ 7/05
+
+WITH REPORT;
+ USE REPORT;
+WITH SYSTEM;
+PROCEDURE C92005B IS
+ TYPE BIG_INT IS RANGE 0..SYSTEM.MAX_INT;
+BEGIN
+ TEST ("C92005B", "TASK VALUE SET BY EXECUTION OF ALLOCATOR");
+
+BLOCK:
+ DECLARE
+ TASK TYPE TT1;
+
+ TYPE ATT1 IS ACCESS TT1;
+
+ TASK BODY TT1 IS
+ BEGIN
+ NULL;
+ END TT1;
+
+ PACKAGE PACK IS
+ END PACK;
+
+ PACKAGE BODY PACK IS
+ POINTER_TT1 : ATT1 := NEW TT1;
+ I : BIG_INT := POINTER_TT1.ALL'STORAGE_SIZE;
+ BEGIN
+ IF NOT EQUAL(INTEGER(I MOD 1024), INTEGER(I MOD 1024)) THEN
+ FAILED ("UNEXPECTED PROBLEM");
+ END IF;
+ END PACK;
+ BEGIN
+ NULL;
+ EXCEPTION
+ WHEN PROGRAM_ERROR | CONSTRAINT_ERROR =>
+ FAILED ("TASK OBJECT VALUE NOT SET DURING " &
+ "EXECUTION OF ALLOCATOR");
+ END BLOCK;
+
+ RESULT;
+
+END C92005B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c92006a.ada b/gcc/testsuite/ada/acats/tests/c9/c92006a.ada
new file mode 100644
index 000000000..f0fd0c8c7
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c92006a.ada
@@ -0,0 +1,93 @@
+-- C92006A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT TASK OBJECTS CAN BE INTERCHANGED BY ASSIGNMENT OF
+-- CORRESPONDING ACCESS TYPE OBJECTS.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C920BIA-B.ADA
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C92006A IS
+
+ TASK TYPE TT1 IS
+ ENTRY E1;
+ ENTRY E2;
+ END TT1;
+
+ TYPE ATT1 IS ACCESS TT1;
+ POINTER_TT1_1, POINTER_TT1_2 : ATT1;
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+ PROCEDURE PROC (P1, P2 : IN OUT ATT1) IS
+ -- SWAP TASK OBJECTS P1, P2.
+ SCRATCH : ATT1;
+ BEGIN
+ SCRATCH := P1;
+ P1 := P2;
+ P2 := SCRATCH;
+
+ P1.E2; -- ENTRY2 SECOND OBJECT.
+ P2.E1; -- VICE VERSA.
+
+ END PROC;
+
+ TASK BODY TT1 IS
+ BEGIN
+ ACCEPT E1 DO
+ PSPY_NUMB (1);
+ END E1;
+ ACCEPT E2 DO
+ PSPY_NUMB (2);
+ END E2;
+ END TT1;
+
+BEGIN
+
+ TEST ("C92006A", "INTERCHANGING TASK OBJECTS");
+ POINTER_TT1_1 := NEW TT1;
+ POINTER_TT1_2 := NEW TT1;
+
+ POINTER_TT1_2.ALL.E1;
+ PROC (POINTER_TT1_1, POINTER_TT1_2);
+ POINTER_TT1_2.E2; -- E2 OF FIRST OBJECT
+-- EACH ENTRY OF EACH TASK OBJECT SHOULD HAVE BEEN CALLED.
+
+ IF SPYNUMB /= 1212 THEN
+ FAILED ("FAILURE TO SWAP TASK OBJECTS " &
+ "IN PROCEDURE PROC");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C92006A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c930001.a b/gcc/testsuite/ada/acats/tests/c9/c930001.a
new file mode 100644
index 000000000..874518990
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c930001.a
@@ -0,0 +1,153 @@
+-- C930001.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- TEST OBJECTIVE:
+-- Check when a dependent task and its master both
+-- terminate as a result of a terminate alternative that
+-- finalization is performed and that the finalization is
+-- performed in the proper order.
+--
+-- TEST DESCRIPTION:
+-- A controlled type with finalization is used to determine
+-- the order in which finalization occurs. The finalization
+-- procedure records the identity of the object being
+-- finalized.
+-- Two tasks, one nested inside the other, both contain
+-- objects of the above finalization type. These tasks
+-- cooperatively terminate so the termination and finalization
+-- order can be noted.
+--
+--
+-- CHANGE HISTORY:
+-- 08 Jan 96 SAIC ACVC 2.1
+-- 09 May 96 SAIC Addressed Reviewer comments.
+--
+--!
+
+
+with Ada.Finalization;
+package C930001_0 is
+ Verbose : constant Boolean := False;
+
+ type Ids is range 0..10;
+ Finalization_Order : array (Ids) of Ids := (Ids => 0);
+ Finalization_Cnt : Ids := 0;
+
+ protected Note is
+ -- serializes concurrent access to Finalization_* above
+ procedure Done (Id : Ids);
+ end Note;
+
+ -- Objects of the following type are used to note the order in
+ -- which finalization occurs.
+ type Has_Finalization is new Ada.Finalization.Limited_Controlled with
+ record
+ Id : Ids;
+ end record;
+ procedure Finalize (Object : in out Has_Finalization);
+end C930001_0;
+
+
+with Report;
+package body C930001_0 is
+
+ protected body Note is
+ procedure Done (Id : Ids) is
+ begin
+ Finalization_Cnt := Finalization_Cnt + 1;
+ Finalization_Order (Finalization_Cnt) := Id;
+ end Done;
+ end Note;
+
+ procedure Finalize (Object : in out Has_Finalization) is
+ begin
+ Note.Done (Object.Id);
+ if Verbose then
+ Report.Comment ("in Finalize for" & Ids'Image (Object.Id));
+ end if;
+ end Finalize;
+end C930001_0;
+
+
+with Report;
+with ImpDef;
+with C930001_0; use C930001_0;
+procedure C930001 is
+begin
+
+ Report.Test ("C930001", "Check that dependent tasks are terminated" &
+ " before the remaining finalization");
+
+ declare
+ task Level_1;
+ task body Level_1 is
+ V1a : C930001_0.Has_Finalization; -------> 4
+ task Level_2 is
+ entry Not_Taken;
+ end Level_2;
+ task body Level_2 is
+ V2 : C930001_0.Has_Finalization; -------> 2
+ begin
+ V2.Id := 2;
+ C930001_0.Note.Done (1); -------> 1
+ select
+ accept Not_Taken;
+ or
+ terminate;
+ -- cooperative termination at this point of
+ -- both tasks
+ end select;
+ end Level_2;
+
+ -- 7.6.1(11) requires that V1b be finalized before V1a
+ V1b : C930001_0.Has_Finalization; -------> 3
+ begin
+ V1a.Id := 4;
+ V1b.Id := 3;
+ end Level_1;
+ begin -- declare
+ while not Level_1'Terminated loop
+ delay ImpDef.Switch_To_New_Task;
+ end loop;
+ C930001_0.Note.Done (5); -------> 5
+
+ -- now check the order
+ for I in Ids range 1..5 loop
+ if Verbose then
+ Report.Comment (Ids'Image (I) &
+ Ids'Image (Finalization_Order (I)));
+ end if;
+ if Finalization_Order (I) /= I then
+ Report.Failed ("Finalization occurred out of order" &
+ " expected:" &
+ Ids'Image (I) &
+ " actual:" &
+ Ids'Image (Finalization_Order (I)));
+ end if;
+ end loop;
+ end;
+
+ Report.Result;
+end C930001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93001a.ada b/gcc/testsuite/ada/acats/tests/c9/c93001a.ada
new file mode 100644
index 000000000..3a3b9833b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93001a.ada
@@ -0,0 +1,296 @@
+-- C93001A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT DECLARED TASK OBJECTS ARE NOT ACTIVATED BEFORE
+-- THE END OF THE DECLARATIVE PART.
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK OBJECT, IN A BLOCK.
+-- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION.
+-- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION.
+-- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY.
+-- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY.
+
+-- THIS TEST ASSUMES THAT ACTIVATION IS A SEQUENTIAL STEP
+-- IN THE FLOW OF CONTROL OF THE PARENT (AS IS REQUIRED BY THE
+-- ADA RM). IF AN IMPLEMENTATION (ILLEGALLY) ACTIVATES A
+-- TASK IN PARALLEL WITH ITS PARENT, THIS TEST
+-- IS NOT GUARANTEED TO DETECT THE VIOLATION, DUE TO A
+-- RACE CONDITION.
+
+-- JRK 9/23/81
+-- SPS 11/1/82
+-- SPS 11/21/82
+-- R.WILLIAMS 10/8/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK
+-- COMPONENTS OF RECORD TYPES.
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93001A IS
+
+ GLOBAL : INTEGER;
+
+ FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS
+ BEGIN
+ GLOBAL := IDENT_INT (I);
+ RETURN 0;
+ END SIDE_EFFECT;
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ I : INTEGER := SIDE_EFFECT (1);
+ BEGIN
+ NULL;
+ END TT;
+
+
+BEGIN
+ TEST ("C93001A", "CHECK THAT DECLARED TASK OBJECTS ARE NOT " &
+ "ACTIVATED BEFORE THE END OF THE DECLARATIVE " &
+
+ "PART");
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (A)
+
+ T : TT;
+ I : INTEGER := GLOBAL;
+
+ BEGIN -- (A)
+
+ IF I /= 0 THEN
+ FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " &
+ "ACTIVATED TOO SOON - (A)");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (B)
+
+ J : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ I : INTEGER := GLOBAL;
+ BEGIN
+ IF I /= 0 THEN
+ FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " &
+ "WAS ACTIVATED TOO SOON - (B)");
+ END IF;
+ RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ J := F ;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C)
+
+ PACKAGE P IS
+
+ TYPE REC IS
+ RECORD
+ T : TT;
+ N1 : INTEGER := GLOBAL;
+ END RECORD;
+
+ TYPE RT IS
+ RECORD
+ M : INTEGER := GLOBAL;
+ T : TT;
+ N : REC;
+ END RECORD;
+ R : RT;
+ I : INTEGER := GLOBAL;
+ END P;
+
+ PACKAGE Q IS
+ J : INTEGER;
+ PRIVATE
+ TYPE RT IS
+ RECORD
+ N : P.REC;
+ T : TT;
+ M : INTEGER := GLOBAL;
+ END RECORD;
+ R : RT;
+ END Q;
+
+ K : INTEGER := GLOBAL;
+
+ PACKAGE BODY Q IS
+ BEGIN
+ IF R.M /= 0 OR R.N.N1 /= 0 THEN
+ FAILED ( "NON-TASK COMPONENTS OF RECORD R NOT " &
+ "INITIALIZED BEFORE TASKS ACTIVATED " &
+ "- (C.1)" );
+ END IF;
+ END Q;
+
+ BEGIN -- (C)
+
+ IF P.R.M /= 0 OR P.R.N.N1 /= 0 THEN
+ FAILED ( "NON-TASK COMPONENTS OF RECORDS NOT " &
+ "INITIALIZED BEFORE TASKS ACTIVATED " &
+ "- (C.2)" );
+ END IF;
+
+ IF P.I /= 0 OR K /= 0 THEN
+ FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " &
+ "SPECIFICATION WAS ACTIVATED TOO SOON - (C)");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (D)
+
+ PACKAGE P IS
+
+ TYPE GRADE IS (GOOD, FAIR, POOR);
+
+ TYPE REC (G : GRADE) IS
+ RECORD
+ NULL;
+ END RECORD;
+
+ TYPE ACCR IS ACCESS REC;
+ TYPE ACCI IS ACCESS INTEGER;
+
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RAT IS
+ RECORD
+ M : ACCR := NEW REC (GRADE'VAL (GLOBAL));
+ A : ARR;
+ N : ACCI := NEW INTEGER'(GLOBAL);
+ END RECORD;
+ RA1 : RAT;
+ PRIVATE
+ RA2 : RAT;
+ END P;
+
+ PACKAGE BODY P IS
+ RA3 : RAT;
+ I : INTEGER := GLOBAL;
+ BEGIN
+ IF RA1.M.G /= GOOD OR RA1.N.ALL /= 0 THEN
+ FAILED ( "NON-TASK COMPONENTS OF RECORD RA1 NOT " &
+ "INITIALIZED BEFORE TASKS ACTIVATED " &
+ "- (D)" );
+ END IF;
+
+ IF RA2.M.G /= GOOD OR RA2.N.ALL /= 0 THEN
+ FAILED ( "NON-TASK COMPONENTS OF RECORD RA2 NOT " &
+ "INITIALIZED BEFORE TASKS ACTIVATED " &
+ "- (D)" );
+ END IF;
+
+ IF RA3.M.G /= GOOD OR RA3.N.ALL /= 0 THEN
+ FAILED ( "NON-TASK COMPONENTS OF RECORD RA3 NOT " &
+ "INITIALIZED BEFORE TASKS ACTIVATED " &
+ "- (D)" );
+ END IF;
+
+ IF I /= 0 THEN
+ FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " &
+ "PACKAGE SPEC OR BODY WAS ACTIVATED " &
+ "TOO SOON - (D)");
+ END IF;
+ END P;
+
+ BEGIN -- (D)
+
+ NULL;
+
+ END; -- (D)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (E)
+
+ TYPE REC IS
+ RECORD
+ B : BOOLEAN := BOOLEAN'VAL (GLOBAL);
+ T : TT;
+ C :CHARACTER :=CHARACTER'VAL (GLOBAL);
+ END RECORD;
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ TYPE RT IS
+ RECORD
+ M : REC;
+ T : TT;
+ N : REC;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ I : INTEGER := GLOBAL;
+ BEGIN
+ IF AR (1).M.B /= FALSE OR AR (1).M.C /= ASCII.NUL OR
+ AR (1).N.B /= FALSE OR AR (1).N.C /= ASCII.NUL THEN
+ FAILED ( "NON-TASK COMPONENTS OF RECORD RT NOT " &
+ "INITIALIZED BEFORE TASKS ACTIVATED " &
+ "- (E)" );
+ END IF;
+
+ IF I /= 0 THEN
+ FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " &
+ "TASK BODY WAS ACTIVATED TOO SOON - (E)");
+ END IF;
+ END T;
+
+ BEGIN -- (E)
+
+ NULL;
+
+ END; -- (E)
+
+ --------------------------------------------------
+
+ RESULT;
+END C93001A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93002a.ada b/gcc/testsuite/ada/acats/tests/c9/c93002a.ada
new file mode 100644
index 000000000..a9999ad2a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93002a.ada
@@ -0,0 +1,231 @@
+-- C93002A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT DECLARED TASK OBJECTS ARE ACTIVATED BEFORE EXECUTION
+-- OF THE FIRST STATEMENT FOLLOWING THE DECLARATIVE PART.
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK OBJECT, IN A BLOCK.
+-- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION.
+-- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION.
+-- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY.
+-- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY.
+
+-- JRK 9/28/81
+-- SPS 11/1/82
+-- SPS 11/21/82
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93002A IS
+
+ GLOBAL : INTEGER;
+
+ FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS
+ BEGIN
+ GLOBAL := IDENT_INT (I);
+ RETURN 0;
+ END SIDE_EFFECT;
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ I : INTEGER := SIDE_EFFECT (1);
+ BEGIN
+ NULL;
+ END TT;
+
+
+BEGIN
+ TEST ("C93002A", "CHECK THAT DECLARED TASK OBJECTS ARE " &
+ "ACTIVATED BEFORE EXECUTION OF THE FIRST " &
+ "STATEMENT FOLLOWING THE DECLARATIVE PART");
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (A)
+
+ T : TT;
+
+ BEGIN -- (A)
+
+ IF GLOBAL /= 1 THEN
+ FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " &
+ "ACTIVATED TOO LATE - (A)");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (B)
+
+ J : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ BEGIN
+ IF GLOBAL /= 1 THEN
+ FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " &
+ "WAS ACTIVATED TOO LATE - (B)");
+ END IF;
+ RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ J := F ;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C1)
+
+ PACKAGE P IS
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RT IS
+ RECORD
+ A : ARR;
+ END RECORD;
+ R : RT;
+ END P;
+
+ PACKAGE BODY P IS
+ BEGIN
+ IF GLOBAL /= 1 THEN
+ FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " &
+ "SPECIFICATION WAS ACTIVATED TOO LATE " &
+ "- (C1)");
+ END IF;
+ END P;
+
+ BEGIN -- (C1)
+
+ NULL;
+
+ END; -- (C1)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C2)
+
+ PACKAGE Q IS
+ J : INTEGER;
+ PRIVATE
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ R : RT;
+ END Q;
+
+ PACKAGE BODY Q IS
+ BEGIN
+ IF GLOBAL /= 1 THEN
+ FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " &
+ "SPECIFICATION WAS ACTIVATED TOO LATE " &
+ "- (C2)");
+ END IF;
+ END Q;
+
+ BEGIN -- (C2)
+
+ NULL;
+
+ END; -- (C2)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (D)
+
+ PACKAGE P IS
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RAT IS
+ RECORD
+ A : ARR;
+ END RECORD;
+ END P;
+
+ PACKAGE BODY P IS
+ RA : RAT;
+ BEGIN
+ IF GLOBAL /= 1 THEN
+ FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " &
+ "PACKAGE BODY WAS ACTIVATED " &
+ "TOO LATE - (D)");
+ END IF;
+ END P;
+
+ BEGIN -- (D)
+
+ NULL;
+
+ END; -- (D)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (E)
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ BEGIN
+ IF GLOBAL /= 1 THEN
+ FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " &
+ "TASK BODY WAS ACTIVATED TOO LATE - (E)");
+ END IF;
+ END T;
+
+ BEGIN -- (E)
+
+ NULL;
+
+ END; -- (E)
+
+ --------------------------------------------------
+
+ RESULT;
+END C93002A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93003a.ada b/gcc/testsuite/ada/acats/tests/c9/c93003a.ada
new file mode 100644
index 000000000..48dced34e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93003a.ada
@@ -0,0 +1,351 @@
+-- C93003A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ACTIVATION OF TASKS CREATED BY ALLOCATORS PRESENT IN A
+-- DECLARATIVE PART TAKES PLACE DURING ELABORATION OF THE
+-- CORRESPONDING DECLARATION.
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK.
+-- (B) AN ARRAY OF TASK ALLOCATOR, IN A FUNCTION.
+-- (C) A RECORD OF TASK ALLOCATOR, IN A PACKAGE SPECIFICATION.
+-- (D) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY.
+-- (E) AN ARRAY OF RECORD OF TASK ALLOCATOR, IN A TASK BODY.
+
+-- JRK 9/28/81
+-- SPS 11/11/82
+-- SPS 11/21/82
+-- RJW 8/4/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK COMPONENTS
+-- OF RECORD TYPES.
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93003A IS
+
+ GLOBAL : INTEGER;
+
+ FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS
+ BEGIN
+ GLOBAL := IDENT_INT (I);
+ RETURN 0;
+ END SIDE_EFFECT;
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ I : INTEGER := SIDE_EFFECT (1);
+ BEGIN
+ NULL;
+ END TT;
+
+
+BEGIN
+ TEST ("C93003A", "CHECK THAT ACTIVATION OF TASKS CREATED BY " &
+ "ALLOCATORS PRESENT IN A DECLARATIVE PART " &
+ "TAKES PLACE DURING ELABORATION OF THE " &
+ "CORRESPONDING DECLARATION");
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (A)
+
+ TYPE A IS ACCESS TT;
+ T1 : A := NEW TT;
+ I1 : INTEGER := GLOBAL;
+ J : INTEGER := SIDE_EFFECT (0);
+ T2 : A := NEW TT;
+ I2 : INTEGER := GLOBAL;
+
+ BEGIN -- (A)
+
+ IF I1 /= 1 OR I2 /= 1 THEN
+ FAILED ("A SIMPLE TASK ALLOCATOR IN A BLOCK WAS " &
+ "ACTIVATED TOO LATE - (A)");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (B)
+
+ J : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+
+ TYPE A_T IS ARRAY (1 .. 1) OF TT;
+ TYPE A IS ACCESS A_T;
+ A1 : A := NEW A_T;
+ I1 : INTEGER := GLOBAL;
+ J : INTEGER := SIDE_EFFECT (0);
+ A2 : A := NEW A_T;
+ I2 : INTEGER := GLOBAL;
+
+ BEGIN
+ IF I1 /= 1 OR I2 /= 1 THEN
+ FAILED ("AN ARRAY OF TASK ALLOCATOR IN A " &
+ "FUNCTION WAS ACTIVATED TOO LATE - (B)");
+ END IF;
+ RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ J := F ;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C1)
+
+ PACKAGE P IS
+
+ TYPE INTREC IS
+ RECORD
+ N1 : INTEGER := GLOBAL;
+ END RECORD;
+
+ TYPE RT IS
+ RECORD
+ M : INTEGER := GLOBAL;
+ T : TT;
+ N : INTREC;
+ END RECORD;
+
+ TYPE A IS ACCESS RT;
+
+ R1 : A := NEW RT;
+ I1 : INTEGER := GLOBAL;
+ J : INTEGER := SIDE_EFFECT (0);
+ R2 : A := NEW RT;
+ I2 : INTEGER := GLOBAL;
+
+ END P;
+
+ BEGIN -- (C1)
+
+ IF P.R1.M /= 0 OR P.R1.N.N1 /= 0 THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED - (C1)" );
+ END IF;
+
+ IF P.R2.M /= 0 OR P.R2.N.N1 /= 0 THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED - (C1)" );
+ END IF;
+
+ IF P.I1 /= 1 OR P.I2 /= 1 THEN
+ FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " &
+ "SPECIFICATION WAS ACTIVATED TOO LATE - (C1)");
+ END IF;
+
+ END; -- (C1)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C2)
+
+ PACKAGE Q IS
+ J1 : INTEGER;
+ PRIVATE
+
+ TYPE GRADE IS (GOOD, FAIR, POOR);
+
+ TYPE REC (G : GRADE) IS
+ RECORD
+ NULL;
+ END RECORD;
+
+ TYPE ACCR IS ACCESS REC;
+
+ TYPE ACCI IS ACCESS INTEGER;
+
+ TYPE RT IS
+ RECORD
+ M : ACCR := NEW REC (GRADE'VAL (GLOBAL));
+ T : TT;
+ N : ACCI := NEW INTEGER'(GLOBAL);
+ END RECORD;
+
+ TYPE A IS ACCESS RT;
+
+ R1 : A := NEW RT;
+ I1 : INTEGER := GLOBAL;
+ J2 : INTEGER := SIDE_EFFECT (0);
+ R2 : A := NEW RT;
+ I2 : INTEGER := GLOBAL;
+
+ END Q;
+
+ PACKAGE BODY Q IS
+ BEGIN
+ IF R1.M.G /= GOOD OR R1.N.ALL /= 0 THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED " &
+ "- (C2)" );
+ END IF;
+
+ IF R2.M.G /= GOOD OR R2.N.ALL /= 0 THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED " &
+ "- (C2)" );
+ END IF;
+
+ IF I1 /= 1 OR I2 /= 1 THEN
+ FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " &
+ "SPECIFICATION WAS ACTIVATED TOO LATE " &
+ "- (C2)");
+ END IF;
+ END Q;
+
+ BEGIN -- (C2)
+
+ NULL;
+
+ END; -- (C2)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (D)
+
+ PACKAGE P IS
+
+ TYPE ARR IS ARRAY (1 .. 1) OF TT;
+ TYPE INTARR IS ARRAY (1 .. 1) OF INTEGER;
+
+ TYPE RAT IS
+ RECORD
+ M : INTARR := (1 => GLOBAL);
+ A : ARR;
+ N : INTARR := (1 => GLOBAL);
+ END RECORD;
+ END P;
+
+ PACKAGE BODY P IS
+
+ TYPE A IS ACCESS RAT;
+
+ RA1 : A := NEW RAT;
+ I1 : INTEGER := GLOBAL;
+ J : INTEGER := SIDE_EFFECT (0);
+ RA2 : A := NEW RAT;
+ I2 : INTEGER := GLOBAL;
+
+ BEGIN
+ IF RA1.M (1) /= 0 OR RA1.N (1) /= 0 THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD RA1 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED " &
+ "- (D)" );
+ END IF;
+
+ IF RA2.M (1) /= 0 OR RA2.N (1) /= 0 THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD RA2 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED " &
+ "- (D)" );
+ END IF;
+
+ IF I1 /= 1 OR I2 /= 1 THEN
+ FAILED ("A RECORD OF ARRAY OF TASK ALLOCATOR IN " &
+ "A PACKAGE BODY WAS ACTIVATED " &
+ "TOO LATE - (D)");
+ END IF;
+ END P;
+
+ BEGIN -- (D)
+
+ NULL;
+
+ END; -- (D)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (E)
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ TYPE RT IS
+ RECORD
+ M : BOOLEAN := BOOLEAN'VAL (GLOBAL);
+ T : TT;
+ N : CHARACTER := CHARACTER'VAL (GLOBAL);
+ END RECORD;
+
+ TYPE ART IS ARRAY (1 .. 1) OF RT;
+ TYPE A IS ACCESS ART;
+
+ AR1 : A := NEW ART;
+ I1 : INTEGER := GLOBAL;
+ J : INTEGER := SIDE_EFFECT (0);
+ AR2 : A := NEW ART;
+ I2 : INTEGER := GLOBAL;
+
+ BEGIN
+ IF AR1.ALL (1).M /= FALSE OR
+ AR1.ALL (1).N /= ASCII.NUL THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD AR1 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED " &
+ "- (E)" );
+ END IF;
+
+ IF AR2.ALL (1).M /= FALSE OR
+ AR2.ALL (1).N /= ASCII.NUL THEN
+ FAILED ("NON-TASK COMPONENTS OF RECORD AR2 NOT " &
+ "INITIALIZED BEFORE TASK ACTIVATED " &
+ "- (E)" );
+ END IF;
+
+ IF I1 /= 1 OR I2 /= 1 THEN
+ FAILED ("AN ARRAY OF RECORD OF TASK ALLOCATOR IN " &
+ "A TASK BODY WAS ACTIVATED TOO LATE - (E)");
+ END IF;
+ END T;
+
+ BEGIN -- (E)
+
+ NULL;
+
+ END; -- (E)
+
+ --------------------------------------------------
+
+ RESULT;
+END C93003A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004a.ada b/gcc/testsuite/ada/acats/tests/c9/c93004a.ada
new file mode 100644
index 000000000..688bec139
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93004a.ada
@@ -0,0 +1,67 @@
+-- C93004A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK BECOMES COMPLETED WHEN AN EXCEPTION OCCURS DURING
+-- ITS ACTIVATION.
+
+-- WEI 3/ 4/82
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C93004A IS
+BEGIN
+
+ TEST ("C93004A", "TASK COMPLETION CAUSED BY EXCEPTION");
+
+BLOCK:
+ DECLARE
+ TYPE I0 IS RANGE 0..1;
+
+ TASK T1 IS
+ ENTRY BYE;
+ END T1;
+
+ TASK BODY T1 IS
+ SUBTYPE I1 IS I0 RANGE 0 .. 2; -- CONSTRAINT ERROR.
+ BEGIN
+ ACCEPT BYE;
+ END T1;
+ BEGIN
+ FAILED ("NO EXCEPTION RAISED");
+ IF NOT T1'TERMINATED THEN
+ FAILED ("TASK NOT TERMINATED");
+ T1.BYE;
+ END IF;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION RAISED");
+ END BLOCK;
+
+ RESULT;
+
+END C93004A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004b.ada b/gcc/testsuite/ada/acats/tests/c9/c93004b.ada
new file mode 100644
index 000000000..0b140f59c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93004b.ada
@@ -0,0 +1,132 @@
+-- C93004B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A
+-- TASK, OTHER TASKS ARE UNAFFECTED.
+
+-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR.
+
+-- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE
+-- TASKING_ERROR
+
+-- JEAN-PIERRE ROSEN 09-MAR-1984
+-- JBG 06/01/84
+-- JBG 05/23/85
+-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93004B IS
+
+BEGIN
+ TEST("C93004B", "EXCEPTIONS DURING ACTIVATION");
+
+ DECLARE
+
+ TASK TYPE T1 IS
+ END T1;
+
+ TASK TYPE T2 IS
+ ENTRY E;
+ END T2;
+
+ ARR_T2: ARRAY(INTEGER RANGE 1..1) OF T2;
+
+ TYPE AT1 IS ACCESS T1;
+
+ PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS BEFORE
+ END START_T1; -- ELABORATION ON T1.
+
+ TASK BODY T1 IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES.
+ TASK T1BIS IS
+ END T1BIS;
+
+ TASK BODY T1BIS IS
+ BEGIN
+ ARR_T2(IDENT_INT(1)).E;
+ FAILED ("RENDEZVOUS COMPLETED - T1BIS");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T1BIS");
+ END T1BIS;
+ BEGIN
+ NULL;
+ END;
+
+ ARR_T2(IDENT_INT(1)).E; -- ARR_T2(1) IS NOW TERMINATED.
+
+ FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1");
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T1");
+ END;
+
+ PACKAGE BODY START_T1 IS
+ V_AT1 : AT1 := NEW T1;
+ END START_T1;
+
+ TASK BODY T2 IS
+ I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR.
+ BEGIN
+ IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN
+ FAILED("T2 ACTIVATED OK");
+ END IF;
+ END T2;
+
+ TASK T3 IS
+ ENTRY E;
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN -- T3 MUST BE ACTIVATED OK.
+ ACCEPT E;
+ END T3;
+
+ BEGIN
+ FAILED ("TASKING_ERROR NOT RAISED IN MAIN");
+ T3.E; -- CLEAN UP.
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ BEGIN
+ T3.E;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("T3 NOT ACTIVATED");
+ END;
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED IN MAIN");
+ WHEN OTHERS =>
+ FAILED ("ABNORMAL EXCEPTION IN MAIN-2");
+ END;
+
+ RESULT;
+END C93004B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004c.ada b/gcc/testsuite/ada/acats/tests/c9/c93004c.ada
new file mode 100644
index 000000000..bb4d68b5b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93004c.ada
@@ -0,0 +1,136 @@
+-- C93004C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A
+-- TASK, OTHER TASKS ARE UNAFFECTED.
+
+-- IF SEVERAL TASKS FAIL THEIR ACTIVATION, ONLY ONE TASKING_ERROR IS
+-- RAISED.
+
+-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR.
+
+-- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE
+-- TASKING_ERROR
+
+-- JEAN-PIERRE ROSEN 09-MAR-1984
+-- JBG 06/01/84
+-- JBG 05/23/85
+-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93004C IS
+
+BEGIN
+ TEST("C93004C", "EXCEPTIONS DURING ACTIVATION");
+
+ DECLARE
+
+ TASK TYPE T1 IS
+ END T1;
+
+ TASK TYPE T2 IS
+ ENTRY E;
+ END T2;
+
+ ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2;
+
+ TYPE AT1 IS ACCESS T1;
+
+ PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS
+ END START_T1; -- BEFORE ELABORATION ON T1.
+
+ TASK BODY T1 IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES.
+ TASK T1BIS IS
+ END T1BIS;
+
+ TASK BODY T1BIS IS
+ BEGIN
+ ARR_T2(IDENT_INT(2)).E;
+ FAILED ("RENDEZVOUS COMPLETED - T3");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T3");
+ END T1BIS;
+ BEGIN
+ NULL;
+ END;
+
+ ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW TERMINATED.
+
+ FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1");
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T1");
+ END;
+
+ PACKAGE BODY START_T1 IS
+ V_AT1 : AT1 := NEW T1;
+ END START_T1;
+
+ TASK BODY T2 IS
+ I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR.
+ BEGIN
+ IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN
+ FAILED("T2 ACTIVATED OK");
+ END IF;
+ END T2;
+
+ TASK T3 IS
+ ENTRY E;
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN -- T3 MUST BE ACTIVATED OK.
+ ACCEPT E;
+ END T3;
+
+ BEGIN
+ FAILED ("TASKING_ERROR NOT RAISED IN MAIN");
+ T3.E; -- CLEAN UP.
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ BEGIN
+ T3.E;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("T3 NOT ACTIVATED");
+ END;
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED IN MAIN");
+ WHEN OTHERS =>
+ FAILED ("ABNORMAL EXCEPTION IN MAIN-2");
+ END;
+
+ RESULT;
+
+END C93004C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004d.ada b/gcc/testsuite/ada/acats/tests/c9/c93004d.ada
new file mode 100644
index 000000000..40eb01fba
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93004d.ada
@@ -0,0 +1,152 @@
+-- C93004D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A
+-- TASK, OTHER TASKS ARE UNAFFECTED.
+
+-- THIS TEST CHECKS THE CASE IN WHICH SOME OF THE OTHER TASKS ARE
+-- PERHAPS ACTIVATED BEFORE THE EXCEPTION OCCURS AND SOME TASKS ARE
+-- PERHAPS ACTIVATED AFTER.
+
+-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR.
+
+-- CHECK THAT TASKS WAITING FOR ENTRIES OF SUCH TASKS RECEIVE
+-- TASKING_ERROR.
+
+-- R. WILLIAMS 8/6/86
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C93004D IS
+
+
+BEGIN
+ TEST ( "C93004D", "CHECK THAT WHEN AN EXCEPTION IS RAISED " &
+ "DURING ACTIVATION OF A TASK, OTHER TASKS " &
+ "ARE NOT AFFECTED. IN THIS TEST, SOME OF THE " &
+ "TASKS ARE PERHAPS ACTIVATED BEFORE THE " &
+ "EXCEPTION OCCURS AND SOME PERHAPS AFTER" );
+
+
+ DECLARE
+
+ TASK T0 IS
+ ENTRY E;
+ END T0;
+
+ TASK TYPE T1 IS
+ END T1;
+
+ TASK TYPE T2 IS
+ ENTRY E;
+ END T2;
+
+ ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2;
+
+ TYPE AT1 IS ACCESS T1;
+
+ TASK BODY T0 IS
+ BEGIN
+ ACCEPT E;
+ END T0;
+
+ PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS
+ END START_T1; -- BEFORE ELABORATION ON T1.
+
+ TASK BODY T1 IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES.
+ TASK T1BIS IS
+ END T1BIS;
+
+ TASK BODY T1BIS IS
+ BEGIN
+ ARR_T2(IDENT_INT(2)).E;
+ FAILED ("RENDEZVOUS COMPLETED - T3");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T3");
+ END T1BIS;
+ BEGIN
+ NULL;
+ END;
+
+ ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW
+ -- TERMINATED.
+
+ FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1");
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T1");
+ END;
+
+ PACKAGE BODY START_T1 IS
+ V_AT1 : AT1 := NEW T1;
+ END START_T1;
+
+ TASK BODY T2 IS
+ I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR.
+ BEGIN
+ IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN
+ FAILED("T2 ACTIVATED OK");
+ END IF;
+ END T2;
+
+ TASK T3 IS
+ ENTRY E;
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN -- T3 MUST BE ACTIVATED OK.
+ ACCEPT E;
+ END T3;
+
+ BEGIN -- T0, ARR_T2 (1 .. 4), T3 ACTIVATED HERE.
+
+ FAILED ("TASKING_ERROR NOT RAISED IN MAIN");
+ T3.E; -- CLEAN UP.
+ T0.E;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ BEGIN
+ T3.E;
+ T0.E;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("T0 OR T3 NOT ACTIVATED");
+ END;
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED IN MAIN");
+ WHEN OTHERS =>
+ FAILED ("ABNORMAL EXCEPTION IN MAIN-2");
+ END;
+
+ RESULT;
+END C93004D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004f.ada b/gcc/testsuite/ada/acats/tests/c9/c93004f.ada
new file mode 100644
index 000000000..9267d3ec8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93004f.ada
@@ -0,0 +1,130 @@
+-- C93004F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A
+-- TASK, OTHER TASKS ARE UNAFFECTED.
+
+-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR.
+
+-- THIS TESTS CHECKS THE CASE IN WHICH THE TASKS ARE CREATED BY THE
+-- ALLOCATION OF A RECORD OF TASKS OR AN ARRAY OF TASKS.
+
+-- R. WILLIAMS 8/7/86
+
+WITH REPORT; USE REPORT;
+
+PROCEDURE C93004F IS
+
+BEGIN
+ TEST ( "C93004F", "CHECK THAT WHEN AN EXCEPTION IS RAISED " &
+ "DURING THE ACTIVATION OF A TASK, OTHER " &
+ "TASKS ARE UNAFFECTED. IN THIS TEST, THE " &
+ "TASKS ARE CREATED BY THE ALLOCATION OF A " &
+ "RECORD OR AN ARRAY OF TASKS" );
+
+ DECLARE
+
+ TASK TYPE T IS
+ ENTRY E;
+ END T;
+
+ TASK TYPE TT;
+
+ TASK TYPE TX IS
+ ENTRY E;
+ END TX;
+
+ TYPE REC IS
+ RECORD
+ TR : T;
+ END RECORD;
+
+ TYPE ARR IS ARRAY (IDENT_INT (1) .. IDENT_INT (1)) OF T;
+
+ TYPE RECX IS
+ RECORD
+ TTX1 : TX;
+ TTT : TT;
+ TTX2 : TX;
+ END RECORD;
+
+ TYPE ACCR IS ACCESS REC;
+ AR : ACCR;
+
+ TYPE ACCA IS ACCESS ARR;
+ AA : ACCA;
+
+ TYPE ACCX IS ACCESS RECX;
+ AX : ACCX;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E;
+ END T;
+
+ TASK BODY TT IS
+ BEGIN
+ AR.TR.E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "TASK AR.TR NOT ACTIVE" );
+ END TT;
+
+ TASK BODY TX IS
+ I : POSITIVE := IDENT_INT (0); -- RAISE
+ -- CONSTRAINT_ERROR.
+ BEGIN
+ IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN
+ FAILED ( "TX ACTIVATED OK" );
+ END IF;
+ END TX;
+
+ BEGIN
+ AR := NEW REC;
+ AA := NEW ARR;
+ AX := NEW RECX;
+
+ FAILED ( "TASKING_ERROR NOT RAISED IN MAIN" );
+
+ AA.ALL (1).E; -- CLEAN UP.
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+
+ BEGIN
+ AA.ALL (1).E;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ( "AA.ALL (1) NOT ACTIVATED" );
+ END;
+
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ( "CONSTRAINT_ERROR RAISED IN MAIN" );
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION IN MAIN" );
+ END;
+
+ RESULT;
+
+END C93004F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005a.ada b/gcc/testsuite/ada/acats/tests/c9/c93005a.ada
new file mode 100644
index 000000000..95626f688
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005a.ada
@@ -0,0 +1,130 @@
+-- C93005A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK
+-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED.
+
+-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A
+-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR.
+
+-- JEAN-PIERRE ROSEN 3/9/84
+-- JBG 06/01/84
+-- JBG 05/23/85
+-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93005A IS
+
+BEGIN
+ TEST("C93005A", "EXCEPTIONS RAISED IN A DECLARATIVE PART " &
+ "CONTAINING TASKS");
+
+ BEGIN
+
+ DECLARE
+ TASK TYPE T1 IS -- CHECKS THAT T2 TERMINATES.
+ END T1;
+
+ TYPE AT1 IS ACCESS T1;
+
+ TASK T2 IS -- WILL NEVER BE ACTIVATED.
+ ENTRY E;
+ END T2;
+
+ PACKAGE RAISE_IT IS
+ END RAISE_IT;
+
+ TASK BODY T2 IS
+ BEGIN
+ FAILED ("T2 ACTIVATED");
+ -- IN CASE OF FAILURE
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T2;
+
+ TASK BODY T1 IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT T3 TERMINATES.
+ TASK T3 IS
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN
+ T2.E;
+ FAILED ("RENDEZVOUS COMPLETED WITHOUT " &
+ "ERROR - T3");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T3");
+ END T3;
+ BEGIN
+ NULL;
+ END;
+
+ T2.E; --T2 IS NOW TERMINATED
+
+ FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1");
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("ABNORMAL EXCEPTION - T1");
+ END;
+
+ PACKAGE BODY RAISE_IT IS
+ PT1 : AT1 := NEW T1;
+ I : POSITIVE := IDENT_INT(0); -- RAISE
+ -- CONSTRAINT_ERROR.
+ BEGIN
+ IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN
+ FAILED ("PACKAGE DIDN'T RAISE EXCEPTION");
+ END IF;
+ END RAISE_IT;
+
+ BEGIN -- CAN'T LEAVE BLOCK UNTIL T1, T2, AND T3 ARE TERM.
+ FAILED ("EXCEPTION NOT RAISED");
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR IN MAIN PROGRAM");
+ WHEN OTHERS =>
+ FAILED ("ABNORMAL EXCEPTION IN MAIN-1");
+ END;
+
+ RESULT;
+
+END C93005A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005b.ada b/gcc/testsuite/ada/acats/tests/c9/c93005b.ada
new file mode 100644
index 000000000..1b621c0de
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005b.ada
@@ -0,0 +1,273 @@
+-- C93005B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK
+-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED.
+
+-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A
+-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR.
+
+-- THIS TEST CHECKS THE CASE IN WHICH SEVERAL TASKS ARE WAITING FOR
+-- ACTIVATION WHEN THE EXCEPTION OCCURS.
+
+-- R. WILLIAMS 8/7/86
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+
+PROCEDURE C93005B IS
+
+
+BEGIN
+ TEST ( "C93005B", "CHECK THAT WHEN AN EXCEPTION IS RAISED IN A " &
+ "DECLARATIVE PART, A TASK DECLARED IN THE " &
+ "SAME DECLARATIVE PART BECOMES TERMINATED. " &
+ "IN THIS CASE, SEVERAL TASKS ARE WAITING FOR " &
+ "ACTIVATION WHEN THE EXCEPTION OCCURS" );
+
+ BEGIN
+
+ DECLARE
+ TASK TYPE TA IS -- CHECKS THAT TX TERMINATES.
+ END TA;
+
+ TYPE ATA IS ACCESS TA;
+
+ TASK TYPE TB IS -- CHECKS THAT TY TERMINATES.
+ END TB;
+
+ TYPE TBREC IS
+ RECORD
+ TTB: TB;
+ END RECORD;
+
+ TASK TX IS -- WILL NEVER BE ACTIVATED.
+ ENTRY E;
+ END TX;
+
+ TASK BODY TA IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT TAB
+ -- TERMINATES.
+ TASK TAB IS
+ END TAB;
+
+ TASK BODY TAB IS
+ BEGIN
+ TX.E;
+ FAILED ( "RENDEZVOUS COMPLETED " &
+ "WITHOUT ERROR - TAB" );
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION " &
+ "- TAB" );
+ END TAB;
+ BEGIN
+ NULL;
+ END;
+
+ TX.E; --TX IS NOW TERMINATED.
+
+ FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " &
+ "- TA" );
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION - TA" );
+ END TA;
+
+ PACKAGE RAISE_IT IS
+ TASK TY IS -- WILL NEVER BE ACTIVATED.
+ ENTRY E;
+ END TY;
+ END RAISE_IT;
+
+ TASK BODY TB IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT TBB
+ -- TERMINATES.
+ TASK TBB IS
+ END TBB;
+
+ TASK BODY TBB IS
+ BEGIN
+ RAISE_IT.TY.E;
+ FAILED ( "RENDEZVOUS COMPLETED " &
+ "WITHOUT ERROR - TBB" );
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION " &
+ "- TBB" );
+ END TBB;
+ BEGIN
+ NULL;
+ END;
+
+ RAISE_IT.TY.E; -- TY IS NOW TERMINATED.
+
+ FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " &
+ "- TB" );
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION - TB" );
+ END TB;
+
+ PACKAGE START_TC IS END START_TC;
+
+ TASK BODY TX IS
+ BEGIN
+ FAILED ( "TX ACTIVATED" );
+ -- IN CASE OF FAILURE.
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END TX;
+
+ PACKAGE START_TZ IS
+ TASK TZ IS -- WILL NEVER BE ACTIVATED.
+ ENTRY E;
+ END TZ;
+ END START_TZ;
+
+ PACKAGE BODY START_TC IS
+ TBREC1 : TBREC; -- CHECKS THAT TY TERMINATES.
+
+ TASK TC IS -- CHECKS THAT TZ TERMINATES.
+ END TC;
+
+ TASK BODY TC IS
+ BEGIN
+ DECLARE -- THIS BLOCK TO CHECK THAT TCB
+ -- TERMINATES.
+
+ TASK TCB IS
+ END TCB;
+
+ TASK BODY TCB IS
+ BEGIN
+ START_TZ.TZ.E;
+ FAILED ( "RENDEZVOUS COMPLETED " &
+ "WITHOUT " &
+ "ERROR - TCB" );
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL " &
+ "EXCEPTION - TCB" );
+ END TCB;
+ BEGIN
+ NULL;
+ END;
+
+ START_TZ.TZ.E; -- TZ IS NOW TERMINATED.
+
+ FAILED ( "RENDEZVOUS COMPLETED WITHOUT " &
+ "ERROR - TC" );
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION - TC" );
+ END TC;
+ END START_TC; -- TBREC1 AND TC ACTIVATED HERE.
+
+ PACKAGE BODY RAISE_IT IS
+ NTA : ATA := NEW TA; -- NTA.ALL ACTIVATED HERE.
+
+ TASK BODY TY IS
+ BEGIN
+ FAILED ( "TY ACTIVATED" );
+ -- IN CASE OF FAILURE.
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END TY;
+
+ PACKAGE XCEPTION IS
+ I : POSITIVE := IDENT_INT (0); -- RAISE
+ -- CONSTRAINT_ERROR.
+ END XCEPTION;
+
+ USE XCEPTION;
+
+ BEGIN -- TY WOULD BE ACTIVATED HERE.
+
+ IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN
+ FAILED ( "PACKAGE DIDN'T RAISE EXCEPTION" );
+ END IF;
+ END RAISE_IT;
+
+ PACKAGE BODY START_TZ IS
+ TASK BODY TZ IS
+ BEGIN
+ FAILED ( "TZ ACTIVATED" );
+ -- IN CASE OF FAILURE.
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END TZ;
+ END START_TZ; -- TZ WOULD BE ACTIVATED HERE.
+
+ BEGIN -- TX WOULD BE ACTIVATED HERE.
+ -- CAN'T LEAVE BLOCK UNTIL TA, TB, AND TC ARE TERM.
+
+ FAILED ( "EXCEPTION NOT RAISED" );
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TASKING_ERROR =>
+ FAILED ( "TASKING_ERROR IN MAIN PROGRAM" );
+ WHEN OTHERS =>
+ FAILED ( "ABNORMAL EXCEPTION IN MAIN" );
+ END;
+
+ RESULT;
+
+END C93005B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005c.ada b/gcc/testsuite/ada/acats/tests/c9/c93005c.ada
new file mode 100644
index 000000000..87322ee91
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005c.ada
@@ -0,0 +1,250 @@
+-- C93005C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE
+-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES
+-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A
+-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR.
+
+-- CASE 1: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE
+-- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART.
+
+-- RAC 19-MAR-1985
+-- JBG 06/03/85
+-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PRAGMA ELABORATE (REPORT);
+
+with Impdef;
+
+PACKAGE C93005C_PK1 IS
+
+ -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED.
+ TASK TYPE UNACTIVATED IS
+ ENTRY E;
+ END UNACTIVATED;
+
+ TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED;
+
+ -- *******************************************
+ -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+ --
+ -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT
+ -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS
+ -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE
+ -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED.
+ -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT
+ -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR
+ -- DECREMENT).
+
+ -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED
+ -- BY ANYONE BUT THEMSELVES.
+ --
+ TASK TYPE MNT_TASK IS
+ END MNT_TASK;
+
+ FUNCTION F RETURN INTEGER;
+
+ -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK
+ -- AND FORCE CALLING F BEFORE CREATING THE TASK.
+ -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE
+ -- COUNT.
+ --
+ TYPE MNT IS
+ RECORD
+ DUMMY : INTEGER := F;
+ T : MNT_TASK;
+ END RECORD;
+
+ PROCEDURE CHECK;
+
+
+ -- *******************************************
+ -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+
+END C93005C_PK1;
+
+
+PACKAGE BODY C93005C_PK1 IS
+
+-- THIS TASK IS CALLED IF AN UNACTIVATED TASK
+-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE.
+
+ TASK T IS
+ ENTRY E;
+ END;
+
+ -- ***********************************************
+ -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND
+-- ARE STILL ACTIVE.
+
+ MNT_COUNT : INTEGER := 0;
+
+-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE
+
+ TASK MNT_COUNTER IS
+ ENTRY INCR;
+ ENTRY DECR;
+ END MNT_COUNTER;
+
+-- SYNCHRONIZING TASK
+
+ TASK BODY MNT_COUNTER IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT INCR DO
+ MNT_COUNT := MNT_COUNT +1;
+ END INCR;
+
+ OR ACCEPT DECR DO
+ MNT_COUNT := MNT_COUNT -1;
+ END DECR;
+
+ OR TERMINATE;
+
+ END SELECT;
+ END LOOP;
+ END MNT_COUNTER;
+
+-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED
+--
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ MNT_COUNTER.INCR;
+ RETURN 0;
+ END F;
+
+-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE
+-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK
+-- ITSELF IS NOT TERMINATED.
+--
+ PROCEDURE CHECK IS
+ BEGIN
+ IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN
+ FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " &
+ "TERMINATED");
+ END IF;
+-- RESET THE COUNT FOR THE NEXT SUBTEST:
+ MNT_COUNT := 0;
+ END CHECK;
+
+-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH
+-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN
+-- DECREMENT THE COUNTER.
+--
+ TASK BODY MNT_TASK IS
+ BEGIN
+ DELAY 5.0 * Impdef.One_Second;
+ MNT_COUNTER.DECR;
+ END MNT_TASK;
+
+ -- ***********************************************
+ -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E DO
+ FAILED ("SOME TYPE U TASK WAS ACTIVATED");
+ END E;
+
+ OR TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED.
+ --
+ TASK BODY UNACTIVATED IS
+ BEGIN
+ T.E;
+ END UNACTIVATED;
+END C93005C_PK1;
+
+WITH REPORT, C93005C_PK1;
+USE REPORT, C93005C_PK1;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93005C IS
+
+
+BEGIN
+
+ TEST("C93005C", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " &
+ "TASKS");
+
+ COMMENT("SUBTEST 1: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " &
+ "SPEC");
+ COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART");
+B1: DECLARE
+ X : MNT;
+ BEGIN
+B2: BEGIN
+B3: DECLARE
+ TYPE ACC_MNT IS ACCESS MNT;
+ T1 : UNACTIVATED;
+ M2 : ACC_MNT := NEW MNT;
+
+ PACKAGE RAISES_EXCEPTION IS
+ T2 : UNACTIVATED;
+ M3 : ACC_MNT := NEW MNT;
+ I : POSITIVE := IDENT_INT(0); -- RAISE
+ -- CONSTRAINT_ERROR EXCEPTION
+ END RAISES_EXCEPTION;
+ USE RAISES_EXCEPTION;
+ BEGIN -- WOULD HAVE BEEN ACTIVATED HERE
+ IF EQUAL (I, I) THEN
+ FAILED ("EXCEPTION NOT RAISED");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN WRONG SCOPE");
+ END B3;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COMMENT ("SUBTEST 1 COMPLETED");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN B2");
+ END B2;
+ END B1;
+
+ CHECK;
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ RESULT;
+END C93005C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005d.ada b/gcc/testsuite/ada/acats/tests/c9/c93005d.ada
new file mode 100644
index 000000000..70925a1f6
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005d.ada
@@ -0,0 +1,289 @@
+-- C93005D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE
+-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES
+-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A
+-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR.
+
+-- CASE 2: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE
+-- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART.
+-- OTHER TASKS HAVE BEEN QUEUED ON THE TASKS' ENTRIES.
+
+-- RAC 19-MAR-1985
+-- JBG 06/03/85
+-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+-- ADDED PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
+
+with Impdef;
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PRAGMA ELABORATE (REPORT);
+PACKAGE C93005D_PK1 IS
+
+ -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED.
+ TASK TYPE UNACTIVATED IS
+ ENTRY E;
+ END UNACTIVATED;
+
+ TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED;
+
+ -- *******************************************
+ -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+ --
+ -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT
+ -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS
+ -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE
+ -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED.
+ -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT
+ -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR
+ -- DECREMENT).
+
+ -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED
+ -- BY ANYONE BUT THEMSELVES.
+ --
+ TASK TYPE MNT_TASK IS
+ END MNT_TASK;
+
+ FUNCTION F RETURN INTEGER;
+
+ -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK
+ -- AND FORCE CALLING F BEFORE CREATING THE TASK.
+ -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE
+ -- COUNT.
+ --
+ TYPE MNT IS
+ RECORD
+ DUMMY : INTEGER := F;
+ T : MNT_TASK;
+ END RECORD;
+
+ PROCEDURE CHECK;
+
+
+ -- *******************************************
+ -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+
+END C93005D_PK1;
+
+
+PACKAGE BODY C93005D_PK1 IS
+
+-- THIS TASK IS CALLED IF AN UNACTIVATED TASK
+-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE.
+
+ TASK T IS
+ ENTRY E;
+ END;
+
+ -- ***********************************************
+ -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND
+-- ARE STILL ACTIVE.
+
+ MNT_COUNT : INTEGER := 0;
+
+-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE
+
+ TASK MNT_COUNTER IS
+ ENTRY INCR;
+ ENTRY DECR;
+ END MNT_COUNTER;
+
+-- SYNCHRONIZING TASK
+
+ TASK BODY MNT_COUNTER IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT INCR DO
+ MNT_COUNT := MNT_COUNT +1;
+ END INCR;
+
+ OR ACCEPT DECR DO
+ MNT_COUNT := MNT_COUNT -1;
+ END DECR;
+
+ OR TERMINATE;
+
+ END SELECT;
+ END LOOP;
+ END MNT_COUNTER;
+
+-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED
+--
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ MNT_COUNTER.INCR;
+ RETURN 0;
+ END F;
+
+-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE
+-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK
+-- ITSELF IS NOT TERMINATED.
+--
+ PROCEDURE CHECK IS
+ BEGIN
+ IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN
+ FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " &
+ "TERMINATED");
+ END IF;
+-- RESET THE COUNT FOR THE NEXT SUBTEST:
+ MNT_COUNT := 0;
+ END CHECK;
+
+-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH
+-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN
+-- DECREMENT THE COUNTER.
+--
+ TASK BODY MNT_TASK IS
+ BEGIN
+ DELAY 5.0 * Impdef.One_Second;
+ MNT_COUNTER.DECR;
+ END MNT_TASK;
+
+ -- ***********************************************
+ -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E DO
+ FAILED ("SOME TYPE U TASK WAS ACTIVATED");
+ END E;
+
+ OR TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED.
+ --
+ TASK BODY UNACTIVATED IS
+ BEGIN
+ T.E;
+ END UNACTIVATED;
+END C93005D_PK1;
+
+WITH C93005D_PK1; USE C93005D_PK1;
+PRAGMA ELABORATE (C93005D_PK1);
+GENERIC
+ T1 : IN OUT UNACTIVATED;
+PACKAGE C93005D_ENQUEUE IS
+ PROCEDURE REQUIRE_BODY;
+END;
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PRAGMA ELABORATE (REPORT);
+PACKAGE BODY C93005D_ENQUEUE IS
+
+ TASK T3 IS
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN
+ T1.E;
+ FAILED ("ENQUEUED CALLER DID NOT GET EXCEPTION");
+ EXCEPTION
+ WHEN TASKING_ERROR => NULL;
+ WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED");
+ END T3;
+
+ PROCEDURE REQUIRE_BODY IS
+ BEGIN
+ NULL;
+ END;
+BEGIN -- T3 CALLS T1 HERE
+ DELAY 1.0 * Impdef.One_Second; -- ENSURE THAT T3 EXECUTES
+END C93005D_ENQUEUE;
+
+WITH REPORT, C93005D_PK1, C93005D_ENQUEUE;
+USE REPORT, C93005D_PK1;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93005D IS
+
+
+BEGIN
+
+ TEST("C93005D", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " &
+ "TASKS");
+
+ COMMENT("SUBTEST 2: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " &
+ "SPEC");
+ COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART");
+ COMMENT(" OTHER TASKS HAVE BEEN ENQUEUED ON THE TASKS' ENTRIES");
+B21: DECLARE
+ X : MNT;
+ BEGIN
+B22: BEGIN
+B23: DECLARE
+ TYPE ACC_MNT IS ACCESS MNT;
+ T1 : UNACTIVATED;
+ Y : ACC_MNT := NEW MNT;
+
+ PACKAGE HAS_UNACTIVATED IS
+ T2 : UNACTIVATED;
+ Z : ACC_MNT := NEW MNT;
+ PACKAGE ENQUEUE1 IS NEW C93005D_ENQUEUE(T1);
+ PACKAGE ENQUEUE2 IS NEW C93005D_ENQUEUE(T2);
+ I : POSITIVE := IDENT_INT(0); -- RAISE
+ -- CONSTRAINT_ERROR EXCEPTION.
+ -- TERMINATES T1 AND T2 AND INDIRECTLY THE 2 T3'S
+ END HAS_UNACTIVATED;
+ USE HAS_UNACTIVATED;
+ BEGIN -- WOULD HAVE BEEN ACTIVATED HERE
+ IF EQUAL (I, I) THEN
+ FAILED ("EXCEPTION NOT RAISED");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN WRONG SCOPE");
+ END B23;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COMMENT("SUBTEST 2 COMPLETED");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN B22");
+ END B22;
+ END B21;
+
+ CHECK;
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ RESULT;
+END C93005D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005e.ada b/gcc/testsuite/ada/acats/tests/c9/c93005e.ada
new file mode 100644
index 000000000..c5d6e29e1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005e.ada
@@ -0,0 +1,247 @@
+-- C93005E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE
+-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES
+-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A
+-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR.
+
+-- CASE 3: TASKS IN PACKAGE SPECIFICATION.
+-- THE TASKS DON'T DEPEND ON THE PACKAGE SPECIFICATION.
+
+-- RAC 19-MAR-1985
+-- JBG 06/03/85
+-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PRAGMA ELABORATE (REPORT);
+PACKAGE C93005E_PK1 IS
+
+ -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED.
+ TASK TYPE UNACTIVATED IS
+ ENTRY E;
+ END UNACTIVATED;
+
+ TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED;
+
+ TYPE BAD_REC IS
+ RECORD
+ T : UNACTIVATED;
+ I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR.
+ END RECORD;
+
+ TYPE ACC_BAD_REC IS ACCESS BAD_REC;
+
+
+ -- *******************************************
+ -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+ --
+ -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT
+ -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS
+ -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE
+ -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED.
+ -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT
+ -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR
+ -- DECREMENT).
+
+ -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED
+ -- BY ANYONE BUT THEMSELVES.
+ --
+ TASK TYPE MNT_TASK IS
+ END MNT_TASK;
+
+ FUNCTION F RETURN INTEGER;
+
+ -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK
+ -- AND FORCE CALLING F BEFORE CREATING THE TASK.
+ -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE
+ -- COUNT.
+ --
+ TYPE MNT IS
+ RECORD
+ DUMMY : INTEGER := F;
+ T : MNT_TASK;
+ END RECORD;
+
+ PROCEDURE CHECK;
+
+
+ -- *******************************************
+ -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+
+END C93005E_PK1;
+
+with Impdef;
+PACKAGE BODY C93005E_PK1 IS
+
+-- THIS TASK IS CALLED IF AN UNACTIVATED TASK
+-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE.
+
+ TASK T IS
+ ENTRY E;
+ END;
+
+ -- ***********************************************
+ -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND
+-- ARE STILL ACTIVE.
+
+ MNT_COUNT : INTEGER := 0;
+
+-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE
+
+ TASK MNT_COUNTER IS
+ ENTRY INCR;
+ ENTRY DECR;
+ END MNT_COUNTER;
+
+-- SYNCHRONIZING TASK
+
+ TASK BODY MNT_COUNTER IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT INCR DO
+ MNT_COUNT := MNT_COUNT +1;
+ END INCR;
+
+ OR ACCEPT DECR DO
+ MNT_COUNT := MNT_COUNT -1;
+ END DECR;
+
+ OR TERMINATE;
+
+ END SELECT;
+ END LOOP;
+ END MNT_COUNTER;
+
+-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED
+--
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ MNT_COUNTER.INCR;
+ RETURN 0;
+ END F;
+
+-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE
+-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK
+-- ITSELF IS NOT TERMINATED.
+--
+ PROCEDURE CHECK IS
+ BEGIN
+ IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN
+ FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " &
+ "TERMINATED");
+ END IF;
+-- RESET THE COUNT FOR THE NEXT SUBTEST:
+ MNT_COUNT := 0;
+ END CHECK;
+
+-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH
+-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN
+-- DECREMENT THE COUNTER.
+--
+ TASK BODY MNT_TASK IS
+ BEGIN
+ DELAY 5.0 * Impdef.One_Second;
+ MNT_COUNTER.DECR;
+ END MNT_TASK;
+
+ -- ***********************************************
+ -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E DO
+ FAILED ("SOME TYPE U TASK WAS ACTIVATED");
+ END E;
+
+ OR TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED.
+ --
+ TASK BODY UNACTIVATED IS
+ BEGIN
+ T.E;
+ END UNACTIVATED;
+END C93005E_PK1;
+
+WITH REPORT, C93005E_PK1;
+USE REPORT, C93005E_PK1;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93005E IS
+
+
+BEGIN
+
+ TEST("C93005E", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " &
+ "TASKS");
+
+ COMMENT("SUBTEST 3: TASK IN DECL PART OF PACKAGE SPEC");
+ COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART");
+B31: DECLARE
+ X : MNT;
+ BEGIN
+B32: BEGIN
+B33: DECLARE
+ PACKAGE RAISES_EXCEPTION IS
+ TYPE ACC_MNT IS ACCESS MNT;
+ Y : ACC_MNT := NEW MNT;
+ PTR : ACC_BAD_REC := NEW BAD_REC;
+ END RAISES_EXCEPTION;
+ BEGIN -- WOULD HAVE BEEN ACTIVATED HERE
+ FAILED("EXCEPTION NOT RAISED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN WRONG SCOPE");
+ END B33;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COMMENT("SUBTEST 3 COMPLETED");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN B32");
+ END B32;
+ END B31;
+
+ CHECK;
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ RESULT;
+END C93005E;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005f.ada b/gcc/testsuite/ada/acats/tests/c9/c93005f.ada
new file mode 100644
index 000000000..c6d6aeb17
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005f.ada
@@ -0,0 +1,255 @@
+-- C93005F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE
+-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES
+-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A
+-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR.
+
+-- CASE 4: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DEPEND ON THE
+-- DECLARATIVE PART.
+
+-- RAC 19-MAR-1985
+-- JBG 06/03/85
+-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+-- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PRAGMA ELABORATE (REPORT);
+PACKAGE C93005F_PK1 IS
+
+ -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED.
+ TASK TYPE UNACTIVATED IS
+ ENTRY E;
+ END UNACTIVATED;
+
+ TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED;
+
+ TYPE BAD_REC IS
+ RECORD
+ T : UNACTIVATED;
+ I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR.
+ END RECORD;
+
+ TYPE ACC_BAD_REC IS ACCESS BAD_REC;
+
+
+ -- *******************************************
+ -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+ --
+ -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT
+ -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS
+ -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE
+ -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED.
+ -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT
+ -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR
+ -- DECREMENT).
+
+ -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED
+ -- BY ANYONE BUT THEMSELVES.
+ --
+ TASK TYPE MNT_TASK IS
+ END MNT_TASK;
+
+ FUNCTION F RETURN INTEGER;
+
+ -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK
+ -- AND FORCE CALLING F BEFORE CREATING THE TASK.
+ -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE
+ -- COUNT.
+ --
+ TYPE MNT IS
+ RECORD
+ DUMMY : INTEGER := F;
+ T : MNT_TASK;
+ END RECORD;
+
+ PROCEDURE CHECK;
+
+
+ -- *******************************************
+ -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+
+END C93005F_PK1;
+
+with Impdef;
+PACKAGE BODY C93005F_PK1 IS
+
+-- THIS TASK IS CALLED IF AN UNACTIVATED TASK
+-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE.
+
+ TASK T IS
+ ENTRY E;
+ END;
+
+ -- ***********************************************
+ -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND
+-- ARE STILL ACTIVE.
+
+ MNT_COUNT : INTEGER := 0;
+
+-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE
+
+ TASK MNT_COUNTER IS
+ ENTRY INCR;
+ ENTRY DECR;
+ END MNT_COUNTER;
+
+-- SYNCHRONIZING TASK
+
+ TASK BODY MNT_COUNTER IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT INCR DO
+ MNT_COUNT := MNT_COUNT +1;
+ END INCR;
+
+ OR ACCEPT DECR DO
+ MNT_COUNT := MNT_COUNT -1;
+ END DECR;
+
+ OR TERMINATE;
+
+ END SELECT;
+ END LOOP;
+ END MNT_COUNTER;
+
+-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED
+--
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ MNT_COUNTER.INCR;
+ RETURN 0;
+ END F;
+
+-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE
+-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK
+-- ITSELF IS NOT TERMINATED.
+--
+ PROCEDURE CHECK IS
+ BEGIN
+ IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN
+ FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " &
+ "TERMINATED");
+ END IF;
+-- RESET THE COUNT FOR THE NEXT SUBTEST:
+ MNT_COUNT := 0;
+ END CHECK;
+
+-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH
+-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN
+-- DECREMENT THE COUNTER.
+--
+ TASK BODY MNT_TASK IS
+ BEGIN
+ DELAY 5.0 * Impdef.One_Second;
+ MNT_COUNTER.DECR;
+ END MNT_TASK;
+
+ -- ***********************************************
+ -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E DO
+ FAILED ("SOME TYPE U TASK WAS ACTIVATED");
+ END E;
+
+ OR TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED.
+ --
+ TASK BODY UNACTIVATED IS
+ BEGIN
+ T.E;
+ END UNACTIVATED;
+END C93005F_PK1;
+
+WITH REPORT, C93005F_PK1;
+USE REPORT, C93005F_PK1;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93005F IS
+
+
+BEGIN
+
+ TEST("C93005F", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " &
+ "TASKS");
+
+ COMMENT("SUBTEST 4: TASK IN STATEMENT PART OF BLOCK");
+ COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART");
+B41: DECLARE
+ X : MNT;
+ BEGIN
+B42: DECLARE
+ TYPE LOCAL_ACC IS ACCESS BAD_REC;
+ Y : MNT;
+ PTR : LOCAL_ACC;
+
+ TYPE ACC_MNT IS ACCESS MNT;
+ Z : ACC_MNT;
+
+ BEGIN
+ Z := NEW MNT;
+ PTR := NEW BAD_REC;
+ IF PTR.I /= REPORT.IDENT_INT(0) THEN
+ FAILED ("EXCEPTION NOT RAISED, VALUE CHANGED");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED, CONSTRAINT IGNORED");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR => NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION IN B42");
+ END B42;
+
+ COMMENT("SUBTEST 4: COMPLETED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ END B41;
+
+ CHECK;
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ RESULT;
+END C93005F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005g.ada b/gcc/testsuite/ada/acats/tests/c9/c93005g.ada
new file mode 100644
index 000000000..c46a7309d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005g.ada
@@ -0,0 +1,245 @@
+-- C93005G.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE
+-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES
+-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A
+-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR.
+
+-- CASE 5: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DON'T DEPEND
+-- ON THE DECLARATIVE PART.
+
+-- RAC 19-MAR-1985
+-- JBG 06/03/85
+-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PRAGMA ELABORATE (REPORT);
+PACKAGE C93005G_PK1 IS
+
+ -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED.
+ TASK TYPE UNACTIVATED IS
+ ENTRY E;
+ END UNACTIVATED;
+
+ TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED;
+
+ TYPE BAD_REC IS
+ RECORD
+ T : UNACTIVATED;
+ I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR.
+ END RECORD;
+
+ TYPE ACC_BAD_REC IS ACCESS BAD_REC;
+
+
+ -- *******************************************
+ -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+ --
+ -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT
+ -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS
+ -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE
+ -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED.
+ -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT
+ -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR
+ -- DECREMENT).
+
+ -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED
+ -- BY ANYONE BUT THEMSELVES.
+ --
+ TASK TYPE MNT_TASK IS
+ END MNT_TASK;
+
+ FUNCTION F RETURN INTEGER;
+
+ -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK
+ -- AND FORCE CALLING F BEFORE CREATING THE TASK.
+ -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE
+ -- COUNT.
+ --
+ TYPE MNT IS
+ RECORD
+ DUMMY : INTEGER := F;
+ T : MNT_TASK;
+ END RECORD;
+
+ PROCEDURE CHECK;
+
+
+ -- *******************************************
+ -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+
+END C93005G_PK1;
+
+with Impdef;
+PACKAGE BODY C93005G_PK1 IS
+
+-- THIS TASK IS CALLED IF AN UNACTIVATED TASK
+-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE.
+
+ TASK T IS
+ ENTRY E;
+ END;
+
+ -- ***********************************************
+ -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND
+-- ARE STILL ACTIVE.
+
+ MNT_COUNT : INTEGER := 0;
+
+-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE
+
+ TASK MNT_COUNTER IS
+ ENTRY INCR;
+ ENTRY DECR;
+ END MNT_COUNTER;
+
+-- SYNCHRONIZING TASK
+
+ TASK BODY MNT_COUNTER IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT INCR DO
+ MNT_COUNT := MNT_COUNT +1;
+ END INCR;
+
+ OR ACCEPT DECR DO
+ MNT_COUNT := MNT_COUNT -1;
+ END DECR;
+
+ OR TERMINATE;
+
+ END SELECT;
+ END LOOP;
+ END MNT_COUNTER;
+
+-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED
+--
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ MNT_COUNTER.INCR;
+ RETURN 0;
+ END F;
+
+-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE
+-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK
+-- ITSELF IS NOT TERMINATED.
+--
+ PROCEDURE CHECK IS
+ BEGIN
+ IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN
+ FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " &
+ "TERMINATED");
+ END IF;
+-- RESET THE COUNT FOR THE NEXT SUBTEST:
+ MNT_COUNT := 0;
+ END CHECK;
+
+-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH
+-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN
+-- DECREMENT THE COUNTER.
+--
+ TASK BODY MNT_TASK IS
+ BEGIN
+ DELAY 5.0 * Impdef.One_Second;
+ MNT_COUNTER.DECR;
+ END MNT_TASK;
+
+ -- ***********************************************
+ -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E DO
+ FAILED ("SOME TYPE U TASK WAS ACTIVATED");
+ END E;
+
+ OR TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED.
+ --
+ TASK BODY UNACTIVATED IS
+ BEGIN
+ T.E;
+ END UNACTIVATED;
+END C93005G_PK1;
+
+WITH REPORT, C93005G_PK1;
+USE REPORT, C93005G_PK1;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93005G IS
+
+
+BEGIN
+
+ TEST("C93005G", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " &
+ "TASKS");
+
+ COMMENT("SUBTEST 5: TASK IN STATEMENT PART OF BLOCK");
+ COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART");
+B51: DECLARE
+ X : MNT;
+ BEGIN
+B52: DECLARE
+ Y : MNT;
+ PTR : ACC_BAD_REC;
+ BEGIN
+ PTR := NEW BAD_REC;
+ FAILED ("EXCEPTION NOT RAISED");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION IN B52");
+ END B52;
+
+ COMMENT ("SUBTEST 5: COMPLETED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ END B51;
+
+ CHECK;
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ RESULT;
+END C93005G;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005h.ada b/gcc/testsuite/ada/acats/tests/c9/c93005h.ada
new file mode 100644
index 000000000..6641347b1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93005h.ada
@@ -0,0 +1,250 @@
+-- C93005H.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE
+-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES
+-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A
+-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR.
+
+-- CASE 6: TASK IN STATEMENT PART OF PACKAGE AND THE TASKS DON'T DEPEND
+-- ON THE PACKAGE SPECIFICATION.
+
+-- RAC 19-MAR-1985
+-- JBG 06/03/85
+-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PRAGMA ELABORATE (REPORT);
+PACKAGE C93005H_PK1 IS
+
+ -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED.
+ TASK TYPE UNACTIVATED IS
+ ENTRY E;
+ END UNACTIVATED;
+
+ TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED;
+
+ TYPE BAD_REC IS
+ RECORD
+ T : UNACTIVATED;
+ I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR.
+ END RECORD;
+
+ TYPE ACC_BAD_REC IS ACCESS BAD_REC;
+
+
+ -- *******************************************
+ -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+ --
+ -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT
+ -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS
+ -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE
+ -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED.
+ -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT
+ -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR
+ -- DECREMENT).
+
+ -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED
+ -- BY ANYONE BUT THEMSELVES.
+ --
+ TASK TYPE MNT_TASK IS
+ END MNT_TASK;
+
+ FUNCTION F RETURN INTEGER;
+
+ -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK
+ -- AND FORCE CALLING F BEFORE CREATING THE TASK.
+ -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE
+ -- COUNT.
+ --
+ TYPE MNT IS
+ RECORD
+ DUMMY : INTEGER := F;
+ T : MNT_TASK;
+ END RECORD;
+
+ PROCEDURE CHECK;
+
+
+ -- *******************************************
+ -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS
+ -- *******************************************
+
+END C93005H_PK1;
+
+with Impdef;
+PACKAGE BODY C93005H_PK1 IS
+
+-- THIS TASK IS CALLED IF AN UNACTIVATED TASK
+-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE.
+
+ TASK T IS
+ ENTRY E;
+ END;
+
+ -- ***********************************************
+ -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND
+-- ARE STILL ACTIVE.
+
+ MNT_COUNT : INTEGER := 0;
+
+-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE
+
+ TASK MNT_COUNTER IS
+ ENTRY INCR;
+ ENTRY DECR;
+ END MNT_COUNTER;
+
+-- SYNCHRONIZING TASK
+
+ TASK BODY MNT_COUNTER IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT INCR DO
+ MNT_COUNT := MNT_COUNT +1;
+ END INCR;
+
+ OR ACCEPT DECR DO
+ MNT_COUNT := MNT_COUNT -1;
+ END DECR;
+
+ OR TERMINATE;
+
+ END SELECT;
+ END LOOP;
+ END MNT_COUNTER;
+
+-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED
+--
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ MNT_COUNTER.INCR;
+ RETURN 0;
+ END F;
+
+-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE
+-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK
+-- ITSELF IS NOT TERMINATED.
+--
+ PROCEDURE CHECK IS
+ BEGIN
+ IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN
+ FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " &
+ "TERMINATED");
+ END IF;
+-- RESET THE COUNT FOR THE NEXT SUBTEST:
+ MNT_COUNT := 0;
+ END CHECK;
+
+-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH
+-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN
+-- DECREMENT THE COUNTER.
+--
+ TASK BODY MNT_TASK IS
+ BEGIN
+ DELAY 5.0 * Impdef.One_Second;
+ MNT_COUNTER.DECR;
+ END MNT_TASK;
+
+ -- ***********************************************
+ -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS
+ -- ***********************************************
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E DO
+ FAILED ("SOME TYPE U TASK WAS ACTIVATED");
+ END E;
+
+ OR TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED.
+ --
+ TASK BODY UNACTIVATED IS
+ BEGIN
+ T.E;
+ END UNACTIVATED;
+END C93005H_PK1;
+
+WITH REPORT, C93005H_PK1;
+USE REPORT, C93005H_PK1;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C93005H IS
+
+
+BEGIN
+
+ TEST("C93005H", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " &
+ "TASKS");
+
+ COMMENT("SUBTEST 6: TASK IN STATEMENT PART OF PACKAGE");
+ COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART");
+B61: DECLARE
+ X : MNT;
+
+ PACKAGE P IS
+ Y : MNT;
+ END P;
+
+ PACKAGE BODY P IS
+ PTR : ACC_BAD_REC;
+ Z : MNT;
+ BEGIN
+ PTR := NEW BAD_REC;
+ FAILED("EXCEPTION NOT RAISED");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN P");
+ END P;
+
+ BEGIN
+ COMMENT ("SUBTEST 6: COMPLETED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ END B61;
+
+ CHECK;
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION NOT ABSORBED");
+ RESULT;
+END C93005H;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93006a.ada b/gcc/testsuite/ada/acats/tests/c9/c93006a.ada
new file mode 100644
index 000000000..81954f247
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93006a.ada
@@ -0,0 +1,69 @@
+-- C93006A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK OBJECT DECLARED IN A LIBRARY PACKAGE SPEC IS
+-- ACTIVATED EVEN IF THE PACKAGE HAS NO BODY.
+
+-- JEAN-PIERRE ROSEN 16-MAR-1984
+-- JBG 6/1/84
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+PACKAGE C93006A0 IS
+ TASK TYPE TT IS
+ ENTRY E;
+ END;
+END C93006A0;
+
+PACKAGE BODY C93006A0 IS
+ TASK BODY TT IS
+ BEGIN
+ ACCEPT E;
+ END;
+END C93006A0;
+
+WITH C93006A0; USE C93006A0;
+PRAGMA ELABORATE(C93006A0);
+PACKAGE C93006A1 IS
+ T : TT;
+END C93006A1;
+
+with Impdef;
+WITH REPORT, C93006A1, SYSTEM;
+USE REPORT, C93006A1, SYSTEM;
+PROCEDURE C93006A IS
+BEGIN
+
+ TEST("C93006A", "CHECK ACTIVATION OF TASK DECLARED IN PACKAGE " &
+ "SPECIFICATION");
+
+ SELECT
+ T.E;
+ OR
+ DELAY 60.0 * Impdef.One_Second;
+ FAILED("RENDEZVOUS NOT ACCEPTED WITHIN 60 SECONDS");
+ END SELECT;
+
+ RESULT;
+END C93006A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93007a.ada b/gcc/testsuite/ada/acats/tests/c9/c93007a.ada
new file mode 100644
index 000000000..9653d662e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93007a.ada
@@ -0,0 +1,113 @@
+-- C93007A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT IF AN ATTEMPT IS MADE TO ACTIVATE A TASK BEFORE ITS
+-- BODY HAS BEEN ELABORATED, THE TASK IS COMPLETED AND "PROGRAM_
+-- ERROR" (RATHER THAN "TASKING_ERROR") IS RAISED.
+
+-- HISTORY:
+-- DHH 03/16/88 CREATED ORIGINAL TEST.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C93007A IS
+
+BEGIN
+
+ TEST("C93007A", "CHECK THAT IF AN ATTEMPT IS MADE TO ACTIVATE " &
+ "A TASK BEFORE ITS BODY HAS BEEN ELABORATED, " &
+ "THE TASK IS COMPLETED AND ""PROGRAM_ERROR"" " &
+ "(RATHER THAN ""TASKING_ERROR"") IS RAISED");
+
+ DECLARE
+ TASK TYPE PROG_ERR IS
+ ENTRY START;
+ END PROG_ERR;
+
+ TYPE REC IS
+ RECORD
+ B : PROG_ERR;
+ END RECORD;
+
+ TYPE ACC IS ACCESS PROG_ERR;
+
+ PACKAGE P IS
+ OBJ : REC;
+ END P;
+
+ PACKAGE BODY P IS
+ BEGIN
+ FAILED("EXCEPTION NOT RAISED - 1");
+ OBJ.B.START;
+ EXCEPTION
+ WHEN PROGRAM_ERROR =>
+ NULL;
+ WHEN TASKING_ERROR =>
+ FAILED("TASKING ERROR RAISED INCORRECTLY");
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED EXCEPTION RAISED");
+ END P;
+
+ PACKAGE Q IS
+ OBJ : ACC;
+ END Q;
+
+ PACKAGE BODY Q IS
+ BEGIN
+ OBJ := NEW PROG_ERR;
+ FAILED("EXCEPTION NOT RAISED - 2");
+ OBJ.START;
+ EXCEPTION
+ WHEN PROGRAM_ERROR =>
+ NULL;
+ WHEN TASKING_ERROR =>
+ FAILED("ACCESS TASKING ERROR RAISED INCORRECTLY");
+ WHEN OTHERS =>
+ FAILED("ACCESS UNEXPECTED EXCEPTION RAISED");
+ END;
+
+ TASK BODY PROG_ERR IS
+ BEGIN
+ ACCEPT START DO
+ IF TRUE THEN
+ COMMENT("IRRELEVANT");
+ END IF;
+ END START;
+ END PROG_ERR;
+ BEGIN
+ NULL;
+ END; -- DECLARE
+
+ RESULT;
+
+EXCEPTION
+ WHEN PROGRAM_ERROR =>
+ FAILED("PROGRAM_ERROR RAISED AT INCORRECT POSITION");
+ RESULT;
+
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED EXCEPTION RAISED");
+ RESULT;
+
+END C93007A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93008a.ada b/gcc/testsuite/ada/acats/tests/c9/c93008a.ada
new file mode 100644
index 000000000..633d17dbc
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93008a.ada
@@ -0,0 +1,108 @@
+-- C93008A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT FOR A TASK CREATED BY AN OBJECT DECLARATION, EXECUTION
+-- DOES NOT PROCEED IN PARALLEL WITH ACTIVATION.
+
+-- R.WILLIAMS 8/20/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C93008A IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ TASK T IS
+ ENTRY FINIT_POS (DIGT : IN ARG);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT FINIT_POS (DIGT : IN ARG) DO
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END FINIT_POS;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+BEGIN
+
+ TEST ("C93008A", "CHECK THAT EXECUTION DOES NOT PROCEED IN " &
+ "PARALLEL WITH ACTIVATION OF A TASK CREATED " &
+ "BY AN OBJECT DECLARATION");
+
+BLOCK:
+ DECLARE
+
+ TASK TYPE TT1;
+
+ TASK TT2;
+
+ T1 : TT1;
+
+ TASK BODY TT1 IS
+ PACKAGE DUMMY IS
+ END DUMMY;
+
+ PACKAGE BODY DUMMY IS
+ BEGIN
+ DELAY 2.0 * Impdef.One_Second;
+ T.FINIT_POS(1);
+ END DUMMY;
+ BEGIN
+ NULL;
+ END TT1;
+
+ TASK BODY TT2 IS
+ PACKAGE DUMMY IS
+ END DUMMY;
+
+ PACKAGE BODY DUMMY IS
+ BEGIN
+ DELAY 2.0 * Impdef.One_Second;
+ T.FINIT_POS(2);
+ END DUMMY;
+ BEGIN
+ NULL;
+ END TT2;
+
+
+ BEGIN -- TASKS ACTIVATED NOW.
+
+ IF SPYNUMB = 12 OR SPYNUMB = 21 THEN
+ NULL;
+ ELSE
+ FAILED ("TASKS NOT ACTIVATED PROPERLY - SPYNUMB HAS " &
+ "ACTUAL VALUE OF: " & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+ END BLOCK;
+
+ RESULT;
+
+END C93008A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c93008b.ada b/gcc/testsuite/ada/acats/tests/c9/c93008b.ada
new file mode 100644
index 000000000..2853acd4e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c93008b.ada
@@ -0,0 +1,103 @@
+-- C93008B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT AFTER CREATION OF A TASK OBJECT BY AN ALLOCATOR, ANY
+-- OPERATION INVOLVING THE RESULT DELIVERED BY THE ALLOCATOR IS
+-- EXECUTED ONLY AFTER THE ACTIVATION OF THE TASK HAS COMPLETED.
+
+-- WEI 3/ 4/82
+-- TBN 12/20/85 RENAMED FROM C930AJA-B.ADA. ADDED DELAY STATEMENT
+-- DURING TASK ACTIVATION.
+-- RJW 4/11/86 ADDED PACKAGE DUMMY.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C93008B IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ RETURN DIGT;
+ END FINIT_POS;
+
+BEGIN
+
+ TEST ("C93008B", "USE OF RESULT AFTER CREATION OF " &
+ "A TASK BY ALLOCATOR");
+
+BLOCK:
+ DECLARE
+
+ TASK TYPE TT1;
+
+ TYPE ATT1 IS ACCESS TT1;
+ TYPE ARRAY_ATT1 IS ARRAY (NATURAL RANGE 2 .. 3) OF ATT1;
+ MY_ARRAY : ARRAY_ATT1;
+ POINTER_TT1 : ATT1;
+
+ TASK BODY TT1 IS
+ PACKAGE DUMMY IS
+ END DUMMY;
+
+ PACKAGE BODY DUMMY IS
+ BEGIN
+ DELAY 2.0 * Impdef.One_Second;
+ DECLARE
+ IDUMMY1 : NATURAL := FINIT_POS (1);
+ BEGIN
+ NULL;
+ END;
+ END DUMMY;
+ BEGIN
+ NULL;
+ END TT1;
+
+ BEGIN
+
+ MY_ARRAY := (2 => NEW TT1, 3 => NULL); -- TASK ACTIVATED NOW.
+ POINTER_TT1 := MY_ARRAY (FINIT_POS (2));
+
+ MY_ARRAY (FINIT_POS (3)) := POINTER_TT1;
+
+ IF SPYNUMB /= 123 THEN
+ IF SPYNUMB = 132 OR SPYNUMB = 13 OR
+ SPYNUMB = 12 OR SPYNUMB = 1 OR
+ SPYNUMB = 0
+ THEN
+ FAILED ("TASK ACTIVATION RIGHT IN TIME, " &
+ "BUT OTHER ERROR");
+ ELSE
+ FAILED ("RESULT OF ALLOCATOR ACCESSED BEFORE " &
+ "TASK ACTIVATION HAS COMPLETED");
+ END IF;
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+ END BLOCK;
+
+ RESULT;
+
+END C93008B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940001.a b/gcc/testsuite/ada/acats/tests/c9/c940001.a
new file mode 100644
index 000000000..2bc1a9ffd
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940001.a
@@ -0,0 +1,212 @@
+-- C940001.A
+--
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a protected object provides coordinated access to
+-- shared data. Check that it can be used to sequence a number of tasks.
+-- Use the protected object to control a single token for which three
+-- tasks compete. Check that only one task is running at a time and that
+-- all tasks get a chance to run sometime.
+--
+-- TEST DESCRIPTION:
+-- Declare a protected type with two entries. A task may call the Take
+-- entry to get a token which allows it to continue processing. If it
+-- has the token, it may call the Give entry to return it. The tasks
+-- implement a discipline whereby only the task with the token may be
+-- active. The test does not require any specific order for the tasks
+-- to run.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 07 Jul 96 SAIC Fixed spelling nits.
+--
+--!
+
+package C940001_0 is
+
+ type Token_Type is private;
+ True_Token : constant Token_Type; -- Create a deferred constant in order
+ -- to provide a component init for the
+ -- protected object
+
+ protected type Token_Mgr_Prot_Unit is
+ entry Take (T : out Token_Type);
+ entry Give (T : in out Token_Type);
+ private
+ Token : Token_Type := True_Token;
+ end Token_Mgr_Prot_Unit;
+
+ function Init_Token return Token_Type; -- call to initialize an
+ -- object of Token_Type
+ function Token_Value (T : Token_Type) return Boolean;
+ -- call to inspect the value of an
+ -- object of Token_Type
+private
+ type Token_Type is new boolean;
+ True_Token : constant Token_Type := true;
+end C940001_0;
+
+--=================================================================--
+
+package body C940001_0 is
+ protected body Token_Mgr_Prot_Unit is
+ entry Take (T : out Token_Type) when Token = true is
+ begin -- Calling task will Take the token, so
+ T := Token; -- check first that token_mgr owns the
+ Token := false; -- token to give, then give it to caller
+ end Take;
+
+ entry Give (T : in out Token_Type) when Token = false is
+ begin -- Calling task will Give the token back,
+ if T = true then -- so first check that token_mgr does not
+ Token := T; -- own the token, then check that the task has
+ T := false; -- the token to give, then take it from the
+ end if; -- task
+ -- if caller does not own the token, then
+ end Give; -- it falls out of the entry body with no
+ end Token_Mgr_Prot_Unit; -- action
+
+ function Init_Token return Token_Type is
+ begin
+ return false;
+ end Init_Token;
+
+ function Token_Value (T : Token_Type) return Boolean is
+ begin
+ return Boolean (T);
+ end Token_Value;
+
+end C940001_0;
+
+--===============================================================--
+
+with Report;
+with ImpDef;
+with C940001_0;
+
+procedure C940001 is
+
+ type TC_Int_Type is range 0..2;
+ -- range is very narrow so that erroneous execution may
+ -- raise Constraint_Error
+
+ type TC_Artifact_Type is record
+ TC_Int : TC_Int_Type := 1;
+ Number_of_Accesses : integer := 0;
+ end record;
+
+ TC_Artifact : TC_Artifact_Type;
+
+ Sequence_Mgr : C940001_0.Token_Mgr_Prot_Unit;
+
+ procedure Bump (Item : in out TC_Int_Type) is
+ begin
+ Item := Item + 1;
+ exception
+ when Constraint_Error =>
+ Report.Failed ("Incremented without corresponding decrement");
+ when others =>
+ Report.Failed ("Bump raised Unexpected Exception");
+ end Bump;
+
+ procedure Decrement (Item : in out TC_Int_Type) is
+ begin
+ Item := Item - 1;
+ exception
+ when Constraint_Error =>
+ Report.Failed ("Decremented without corresponding increment");
+ when others =>
+ Report.Failed ("Decrement raised Unexpected Exception");
+ end Decrement;
+
+ --==============--
+
+ task type Network_Node_Type;
+
+ task body Network_Node_Type is
+
+ Slot_for_Token : C940001_0.Token_Type := C940001_0.Init_Token;
+
+ begin
+
+ -- Ask for token - if request is not granted, task will be queued
+ Sequence_Mgr.Take (Slot_for_Token);
+
+ -- Task now has token and may perform its work
+
+ --==========================--
+ -- in this case, the work is to ensure that the test results
+ -- are the expected ones!
+ --==========================--
+ Bump (TC_Artifact.TC_Int); -- increment when request is granted
+ TC_Artifact.Number_Of_Accesses :=
+ TC_Artifact.Number_Of_Accesses + 1;
+ if not C940001_0.Token_Value ( Slot_for_Token) then
+ Report.Failed ("Incorrect results from entry Take");
+ end if;
+
+ -- give a chance for other tasks to (incorrectly) run
+ delay ImpDef.Minimum_Task_Switch;
+
+ Decrement (TC_Artifact.TC_Int); -- prepare to return token
+
+ -- Task has completed its work and will return token
+
+ Sequence_Mgr.Give (Slot_for_Token); -- return token to sequence manager
+
+ if c940001_0.Token_Value (Slot_for_Token) then
+ Report.Failed ("Incorrect results from entry Give");
+ end if;
+
+ exception
+ when others => Report.Failed ("Unexpected exception raised in task");
+
+ end Network_Node_Type;
+
+ --==============--
+
+begin
+
+ Report.Test ("C940001", "Check that a protected object can control " &
+ "tasks by coordinating access to shared data");
+
+ declare
+ Node_1, Node_2, Node_3 : Network_Node_Type;
+ -- declare three tasks which will compete for
+ -- a single token, managed by Sequence Manager
+
+ begin -- tasks start
+ null;
+ end; -- wait for all tasks to terminate before reporting result
+
+ if TC_Artifact.Number_of_Accesses /= 3 then
+ Report.Failed ("Not all tasks got through");
+ end if;
+
+ Report.Result;
+
+end C940001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940002.a b/gcc/testsuite/ada/acats/tests/c9/c940002.a
new file mode 100644
index 000000000..420f54440
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940002.a
@@ -0,0 +1,309 @@
+-- C940002.A
+--
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a protected object provides coordinated access to shared
+-- data. Check that it can implement a semaphore-like construct using a
+-- parameterless procedure which allows a specific maximum number of tasks
+-- to run and excludes all others
+--
+-- TEST DESCRIPTION:
+-- Implement a counting semaphore type that can be initialized to a
+-- specific number of available resources. Declare an entry for
+-- requesting a resource and a procedure for releasing it. Declare an
+-- object of this type, initialized to two resources. Declare and start
+-- three tasks each of which asks for a resource. Verify that only two
+-- resources are granted and that the last task in is queued.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+package C940002_0 is
+ -- Semaphores
+
+ protected type Semaphore_Type (Resources_Available : Integer :=1) is
+ entry Request;
+ procedure Release;
+ function Available return Integer;
+ private
+ Currently_Available : Integer := Resources_Available;
+ end Semaphore_Type;
+
+ Max_Resources : constant Integer := 2;
+ Resource : Semaphore_Type (Max_Resources);
+
+end C940002_0;
+ -- Semaphores;
+
+
+ --========================================================--
+
+
+package body C940002_0 is
+ -- Semaphores
+
+ protected body Semaphore_Type is
+
+ entry Request when Currently_Available >0 is -- when granted, secures
+ begin -- a resource
+ Currently_Available := Currently_Available - 1;
+ end Request;
+
+ procedure Release is -- when called, releases
+ begin -- a resource
+ Currently_Available := Currently_Available + 1;
+ end Release;
+
+ function Available return Integer is -- returns number of
+ begin -- available resources
+ return Currently_Available;
+ end Available;
+
+ end Semaphore_Type;
+
+end C940002_0;
+ -- Semaphores;
+
+
+ --========================================================--
+
+
+package C940002_1 is
+ -- Task_Pkg
+
+ task type Requesting_Task is
+ entry Done; -- call on Done instructs the task
+ end Requesting_Task; -- to release resource
+
+ type Task_Ptr is access Requesting_Task;
+
+ protected Counter is
+ procedure Increment;
+ procedure Decrement;
+ function Number return integer;
+ private
+ Count : Integer := 0;
+ end Counter;
+
+ protected Hold_Lock is
+ procedure Lock;
+ procedure Unlock;
+ function Locked return Boolean;
+ private
+ Lock_State : Boolean := true; -- starts out locked
+ end Hold_Lock;
+
+
+end C940002_1;
+ -- Task_Pkg
+
+
+ --========================================================--
+
+
+with Report;
+with C940002_0;
+ -- Semaphores;
+
+package body C940002_1 is
+ -- Task_Pkg is
+
+ protected body Counter is
+
+ procedure Increment is
+ begin
+ Count := Count + 1;
+ end Increment;
+
+ procedure Decrement is
+ begin
+ Count := Count - 1;
+ end Decrement;
+
+ function Number return Integer is
+ begin
+ return Count;
+ end Number;
+
+ end Counter;
+
+
+ protected body Hold_Lock is
+
+ procedure Lock is
+ begin
+ Lock_State := true;
+ end Lock;
+
+ procedure Unlock is
+ begin
+ Lock_State := false;
+ end Unlock;
+
+ function Locked return Boolean is
+ begin
+ return Lock_State;
+ end Locked;
+
+ end Hold_Lock;
+
+
+ task body Requesting_Task is
+ begin
+ C940002_0.Resource.Request; -- request a resource
+ -- if resource is not available,
+ -- task will be queued to wait
+ Counter.Increment; -- add to count of resources obtained
+ Hold_Lock.Unlock; -- and unlock Lock - system is stable;
+ -- status may now be queried
+
+ accept Done do -- hold resource until Done is called
+ C940002_0.Resource.Release; -- release the resource and
+ Counter.Decrement; -- note release
+ end Done;
+
+ exception
+ when others => Report.Failed ("Unexpected Exception in Requesting_Task");
+ end Requesting_Task;
+
+end C940002_1;
+ -- Task_Pkg;
+
+
+ --========================================================--
+
+
+with Report;
+with ImpDef;
+with C940002_0,
+ -- Semaphores,
+ C940002_1;
+ -- Task_Pkg;
+
+procedure C940002 is
+
+ package Semaphores renames C940002_0;
+ package Task_Pkg renames C940002_1;
+
+ Ptr1,
+ Ptr2,
+ Ptr3 : Task_Pkg.Task_Ptr;
+ Num : Integer;
+
+ procedure Spinlock is
+ begin
+ -- loop until unlocked
+ while Task_Pkg.Hold_Lock.Locked loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ Task_Pkg.Hold_Lock.Lock;
+ end Spinlock;
+
+begin
+
+ Report.Test ("C940002", "Check that a protected record can be used to " &
+ "control access to resources");
+
+ if (Task_Pkg.Counter.Number /=0)
+ or (Semaphores.Resource.Available /= 2) then
+ Report.Failed ("Wrong initial conditions");
+ end if;
+
+ Ptr1 := new Task_Pkg.Requesting_Task; -- newly allocated task requests
+ -- resource; request for resource should
+ -- be granted
+ Spinlock; -- ensure that task obtains resource
+
+ -- Task 1 waiting for call to Done
+ -- One resource assigned to task 1
+ -- One resource still available
+ if (Task_Pkg.Counter.Number /= 1)
+ or (Semaphores.Resource.Available /= 1) then
+ Report.Failed ("Resource not assigned to task 1");
+ end if;
+
+ Ptr2 := new Task_Pkg.Requesting_Task; -- newly allocated task requests
+ -- resource; request for resource should
+ -- be granted
+ Spinlock; -- ensure that task obtains resource
+
+ -- Task 1 waiting for call to Done
+ -- Task 2 waiting for call to Done
+ -- Resources held by tasks 1 and 2
+ -- No resources available
+ if (Task_Pkg.Counter.Number /= 2)
+ or (Semaphores.Resource.Available /= 0) then
+ Report.Failed ("Resource not assigned to task 2");
+ end if;
+
+ Ptr3 := new Task_Pkg.Requesting_Task; -- newly allocated task requests
+ -- resource; request for resource should
+ -- be denied and task queued to wait for
+ -- next available resource
+
+
+ Ptr1.all.Done; -- Task 1 releases resource and lock
+ -- Resource should be given to queued task
+ Spinlock; -- ensure that resource is released
+
+
+ -- Task 1 holds no resource
+ -- One resource still assigned to task 2
+ -- One resource assigned to task 3
+ -- No resources available
+ if (Task_Pkg.Counter.Number /= 2)
+ or (Semaphores.Resource.Available /= 0) then
+ Report.Failed ("Resource not properly released/assigned to task 3");
+ end if;
+
+ Ptr2.all.Done; -- Task 2 releases resource and lock
+ -- No outstanding request for resource
+
+ -- Tasks 1 and 2 hold no resources
+ -- One resource assigned to task 3
+ -- One resource available
+ if (Task_Pkg.Counter.Number /= 1)
+ or (Semaphores.Resource.Available /= 1) then
+ Report.Failed ("Resource not properly released from task 2");
+ end if;
+
+ Ptr3.all.Done; -- Task 3 releases resource and lock
+
+ -- All resources released
+ -- All tasks terminated (or close)
+ -- Two resources available
+ if (Task_Pkg.Counter.Number /=0)
+ or (Semaphores.Resource.Available /= 2) then
+ Report.Failed ("Resource not properly released from task 3");
+ end if;
+
+ Report.Result;
+
+end C940002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940004.a b/gcc/testsuite/ada/acats/tests/c9/c940004.a
new file mode 100644
index 000000000..059c97f41
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940004.a
@@ -0,0 +1,416 @@
+-- C940004.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- TEST OBJECTIVE:
+-- Check that a protected record can be used to control access to
+-- resources (data internal to the protected record).
+--
+-- TEST DESCRIPTION:
+-- Declare a resource descriptor tagged type. Extend the type and
+-- use the extended type in a protected data structure.
+-- Implement a binary semaphore type. Declare an entry for
+-- requesting a specific resource and an procedure for releasing the
+-- same resource. Declare an object of this (protected) type.
+-- Declare and start three tasks each of which asks for a resource
+-- when directed to. Verify that resources are properly allocated
+-- and deallocated.
+--
+--
+-- CHANGE HISTORY:
+--
+-- 12 DEC 93 SAIC Initial PreRelease version
+-- 23 JUL 95 SAIC Second PreRelease version
+-- 16 OCT 95 SAIC ACVC 2.1
+-- 13 MAR 03 RLB Fixed race condition in test.
+--
+--!
+
+package C940004_0 is
+-- Resource_Pkg
+
+ type ID_Type is new Integer range 0..10;
+ type User_Descriptor_Type is tagged record
+ Id : ID_Type := 0;
+ end record;
+
+end C940004_0; -- Resource_Pkg
+
+--============================--
+-- no body for C940004_0
+--=============================--
+
+with C940004_0; -- Resource_Pkg
+
+-- This generic package implements a semaphore to control a single resource
+
+generic
+
+ type Generic_Record_Type is new C940004_0.User_Descriptor_Type
+ with private;
+
+package C940004_1 is
+-- Generic_Semaphore_Pkg
+ -- generic package extends the tagged formal generic
+ -- type with some implementation relevant details, and
+ -- it provides a semaphore with operations that work
+ -- on that type
+ type User_Rec_Type is new Generic_Record_Type with private;
+
+ protected type Semaphore_Type is
+ function TC_Count return Integer;
+ entry Request (R : in out User_Rec_Type);
+ procedure Release (R : in out User_Rec_Type);
+ private
+ In_Use : Boolean := false;
+ end Semaphore_Type;
+
+ function Has_Access (R : User_Rec_Type) return Boolean;
+
+private
+
+ type User_Rec_Type is new Generic_Record_Type with record
+ Access_To_Resource : boolean := false;
+ end record;
+
+end C940004_1; -- Generic_Semaphore_Pkg
+
+--===================================================--
+
+package body C940004_1 is
+-- Generic_Semaphore_Pkg
+
+ protected body Semaphore_Type is
+
+ function TC_Count return Integer is
+ begin
+ return Request'Count;
+ end TC_Count;
+
+ entry Request (R : in out User_Rec_Type)
+ when not In_Use is
+ begin
+ In_Use := true;
+ R.Access_To_Resource := true;
+ end Request;
+
+ procedure Release (R : in out User_Rec_Type) is
+ begin
+ In_Use := false;
+ R.Access_To_Resource := false;
+ end Release;
+
+ end Semaphore_Type;
+
+ function Has_Access (R : User_Rec_Type) return Boolean is
+ begin
+ return R.Access_To_Resource;
+ end Has_Access;
+
+end C940004_1; -- Generic_Semaphore_Pkg
+
+--=============================================--
+
+with Report;
+with C940004_0; -- Resource_Pkg,
+with C940004_1; -- Generic_Semaphore_Pkg;
+
+package C940004_2 is
+-- Printer_Mgr_Pkg
+
+ -- Instantiate the generic to get code to manage a single printer;
+ -- User processes contend for the printer, asking for it by a call
+ -- to Request, and relinquishing it by a call to Release
+
+ -- This package extends a tagged type to customize it for the printer
+ -- in question, then it uses the type to instantiate the generic and
+ -- declare a semaphore specific to the particular resource
+
+ package Resource_Pkg renames C940004_0;
+
+ type User_Desc_Type is new Resource_Pkg.User_Descriptor_Type with record
+ New_Details : Integer := 0; -- for example
+ end record;
+
+ package Instantiation is new C940004_1 -- Generic_Semaphore_Pkg
+ (Generic_Record_Type => User_Desc_Type);
+
+ Printer_Access_Mgr : Instantiation.Semaphore_Type;
+
+
+end C940004_2; -- Printer_Mgr_Pkg
+
+--============================--
+-- no body for C940004_2
+--============================--
+
+with C940004_0; -- Resource_Pkg,
+with C940004_2; -- Printer_Mgr_Pkg;
+
+package C940004_3 is
+-- User_Task_Pkg
+
+-- This package models user tasks that will request and release
+-- the printer
+ package Resource_Pkg renames C940004_0;
+ package Printer_Mgr_Pkg renames C940004_2;
+
+ task type User_Task_Type (ID : Resource_Pkg.ID_Type) is
+ entry Get_Printer; -- instructs task to request resource
+
+ entry Release_Printer -- instructs task to release printer
+ (Descriptor : in out Printer_Mgr_pkg.Instantiation.User_Rec_Type);
+
+ --==================--
+ -- Test management machinery
+ --==================--
+ entry TC_Get_Descriptor -- returns descriptor
+ (Descriptor : out Printer_Mgr_Pkg.Instantiation.User_Rec_Type);
+
+ end User_Task_Type;
+
+ --==================--
+ -- Test management machinery
+ --==================--
+ TC_Times_Obtained : Integer := 0;
+ TC_Times_Released : Integer := 0;
+
+end C940004_3; -- User_Task_Pkg;
+
+--==============================================--
+
+with Report;
+with C940004_0; -- Resource_Pkg,
+with C940004_2; -- Printer_Mgr_Pkg,
+
+package body C940004_3 is
+-- User_Task_Pkg
+
+ task body User_Task_Type is
+ D : Printer_Mgr_Pkg.Instantiation.User_Rec_Type;
+ begin
+ D.Id := ID;
+ -----------------------------------
+ Main:
+ loop
+ select
+ accept Get_Printer;
+ Printer_Mgr_Pkg.Printer_Access_Mgr.Request (D);
+ -- request resource; if resource is not available,
+ -- task will be queued to wait
+ --===================--
+ -- Test management machinery
+ --===================--
+ TC_Times_Obtained := TC_Times_Obtained + 1;
+ -- when request granted, note it and post a message
+
+ or
+ accept Release_Printer (Descriptor : in out
+ Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do
+
+ Printer_Mgr_Pkg.Printer_Access_Mgr.Release (D);
+ -- release the resource, note its release
+ TC_Times_Released := TC_Times_Released + 1;
+ Descriptor := D;
+ end Release_Printer;
+ exit Main;
+
+ or
+ accept TC_Get_Descriptor (Descriptor : out
+ Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do
+
+ Descriptor := D;
+ end TC_Get_Descriptor;
+
+ end select;
+ end loop main;
+
+ exception
+ when others => Report.Failed ("exception raised in User_Task");
+ end User_Task_Type;
+
+end C940004_3; -- User_Task_Pkg;
+
+--==========================================================--
+
+with Report;
+with ImpDef;
+
+with C940004_0; -- Resource_Pkg,
+with C940004_2; -- Printer_Mgr_Pkg,
+with C940004_3; -- User_Task_Pkg;
+
+procedure C940004 is
+ Verbose : constant Boolean := False;
+ package Resource_Pkg renames C940004_0;
+ package Printer_Mgr_Pkg renames C940004_2;
+ package User_Task_Pkg renames C940004_3;
+
+ Task1 : User_Task_Pkg.User_Task_Type (1);
+ Task2 : User_Task_Pkg.User_Task_Type (2);
+ Task3 : User_Task_Pkg.User_Task_Type (3);
+
+ User_Rec_1,
+ User_Rec_2,
+ User_Rec_3 : Printer_Mgr_Pkg.Instantiation.User_Rec_Type;
+
+begin
+
+ Report.Test ("C940004", "Check that a protected record can be used to " &
+ "control access to resources");
+
+ if (User_Task_Pkg.TC_Times_Obtained /= 0)
+ or (User_Task_Pkg.TC_Times_Released /= 0)
+ or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1)
+ or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2)
+ or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then
+ Report.Failed ("Wrong initial conditions");
+ end if;
+
+ Task1.Get_Printer; -- ask for resource
+ -- request for resource should be granted
+ Task1.TC_Get_Descriptor (User_Rec_1);-- wait here 'til task gets resource
+
+ if (User_Task_Pkg.TC_Times_Obtained /= 1)
+ or (User_Task_Pkg.TC_Times_Released /= 0)
+ or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) then
+ Report.Failed ("Resource not assigned to task 1");
+ end if;
+
+ Task2.Get_Printer; -- ask for resource
+ -- request for resource should be denied
+ -- and task queued to wait
+
+ -- Task 1 still waiting to accept Release_Printer, still holds resource
+ -- Task 2 queued on Semaphore.Request
+
+ -- Ensure that Task2 is queued before continuing to make checks and queue
+ -- Task3. We use a for loop here to avoid hangs in broken implementations.
+ for TC_Cnt in 1 .. 20 loop
+ exit when Printer_Mgr_Pkg.Printer_Access_Mgr.TC_Count >= 1;
+ delay Impdef.Minimum_Task_Switch;
+ end loop;
+
+ if (User_Task_Pkg.TC_Times_Obtained /= 1)
+ or (User_Task_Pkg.TC_Times_Released /= 0) then
+ Report.Failed ("Resource assigned to task 2");
+ end if;
+
+ Task3.Get_Printer; -- ask for resource
+ -- request for resource should be denied
+ -- and task 3 queued on Semaphore.Request
+
+ Task1.Release_Printer (User_Rec_1);-- task 1 releases resource
+ -- released resource should be given to
+ -- queued task 2.
+
+ Task2.TC_Get_Descriptor (User_Rec_2);-- wait here for task 2
+
+ -- Task 1 has released resource and completed
+ -- Task 2 has seized the resource
+ -- Task 3 is queued on Semaphore.Request
+
+ if (User_Task_Pkg.TC_Times_Obtained /= 2)
+ or (User_Task_Pkg.TC_Times_Released /= 1)
+ or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1)
+ or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) then
+ Report.Failed ("Resource not properly released/assigned" &
+ " to task 2");
+ if Verbose then
+ Report.Comment ("TC_Times_Obtained: " &
+ Integer'Image (User_Task_Pkg.TC_Times_Obtained));
+ Report.Comment ("TC_Times_Released: " &
+ Integer'Image (User_Task_Pkg.TC_Times_Released));
+ Report.Comment ("User 1 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_1)));
+ Report.Comment ("User 2 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_2)));
+ end if;
+ end if;
+
+ Task2.Release_Printer (User_Rec_2);-- task 2 releases resource
+
+ -- task 3 is released from queue, and is given resource
+
+ Task3.TC_Get_Descriptor (User_Rec_3);-- wait for task 3
+
+ if (User_Task_Pkg.TC_Times_Obtained /= 3)
+ or (User_Task_Pkg.TC_Times_Released /= 2)
+ or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2)
+ or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then
+ Report.Failed ("Resource not properly released/assigned " &
+ "to task 3");
+ if Verbose then
+ Report.Comment ("TC_Times_Obtained: " &
+ Integer'Image (User_Task_Pkg.TC_Times_Obtained));
+ Report.Comment ("TC_Times_Released: " &
+ Integer'Image (User_Task_Pkg.TC_Times_Released));
+ Report.Comment ("User 1 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_1)));
+ Report.Comment ("User 2 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_2)));
+ Report.Comment ("User 3 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_3)));
+ end if;
+ end if;
+
+ Task3.Release_Printer (User_Rec_3);-- task 3 releases resource
+
+ if (User_Task_Pkg.TC_Times_Obtained /=3)
+ or (User_Task_Pkg.TC_Times_Released /=3)
+ or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then
+ Report.Failed ("Resource not properly released by task 3");
+ if Verbose then
+ Report.Comment ("TC_Times_Obtained: " &
+ Integer'Image (User_Task_Pkg.TC_Times_Obtained));
+ Report.Comment ("TC_Times_Released: " &
+ Integer'Image (User_Task_Pkg.TC_Times_Released));
+ Report.Comment ("User 1 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_1)));
+ Report.Comment ("User 2 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_2)));
+ Report.Comment ("User 3 Has_Access:" &
+ Boolean'Image (Printer_Mgr_Pkg.Instantiation.
+ Has_Access (User_Rec_3)));
+ end if;
+
+ end if;
+
+ -- Ensure that all tasks have terminated before reporting the result
+ while not (Task1'terminated
+ and Task2'terminated
+ and Task3'terminated) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C940004;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940005.a b/gcc/testsuite/ada/acats/tests/c9/c940005.a
new file mode 100644
index 000000000..47a97bf2d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940005.a
@@ -0,0 +1,370 @@
+-- C940005.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the body of a protected function can have internal calls
+-- to other protected functions and that the body of a protected
+-- procedure can have internal calls to protected procedures and to
+-- protected functions.
+--
+-- TEST DESCRIPTION:
+-- Simulate a meter at a freeway on-ramp which, when real-time sensors
+-- determine that the freeway is becoming saturated, triggers stop lights
+-- which control the access of vehicles to prevent further saturation.
+-- Each on-ramp is represented by a protected object - in this case only
+-- one is shown (Test_Ramp). The routines to sample and alter the states
+-- of the various sensors, to queue the vehicles on the meter and to
+-- release them are all part of the protected object and can be shared
+-- by various tasks. Apart from the function/procedure tests this example
+-- has a mix of other tasking features.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 13 Nov 95 SAIC Updated and fixed bugs ACVC 2.0.1
+--
+--!
+
+
+with Report;
+with ImpDef;
+with Ada.Calendar;
+
+procedure C940005 is
+
+begin
+
+ Report.Test ("C940005", "Check internal calls of protected functions" &
+ " and procedures");
+
+ declare -- encapsulate the test
+
+ function "+" (Left : Ada.Calendar.Time; Right: Duration)
+ return Ada.Calendar.Time renames Ada.Calendar."+";
+
+ -- Weighted load given to each potential problem area and accumulated
+ type Load_Factor is range 0..8;
+ Clear_Level : constant Load_Factor := 0;
+ Minimum_Level : constant Load_Factor := 1;
+ Moderate_Level : constant Load_Factor := 2;
+ Serious_Level : constant Load_Factor := 4;
+ Critical_Level : constant Load_Factor := 6;
+
+ -- Weighted loads given to each Sample Point (pure weights, not levels)
+ Local_Overload_wt : constant Load_Factor := 1;
+ Next_Ramp_in_Overload_wt : constant Load_Factor := 1;
+ Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght
+ -- :::: other weighted loads
+
+ TC_Multiplier : integer := 1; -- changed half way through
+ TC_Expected_Passage_Total : constant integer := 486;
+
+ -- This is the time between synchronizing pulses to the ramps.
+ -- In reality one would expect a time of 5 to 10 seconds. In
+ -- the interests of speeding up the test suite a shorter time
+ -- is used
+ Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task;
+
+ -- control over stopping tasks
+ protected Control is
+ procedure Stop_Now;
+ function Stop return Boolean;
+ private
+ Halt : Boolean := False;
+ end Control;
+
+ protected body Control is
+ procedure Stop_Now is
+ begin
+ Halt := True;
+ end Stop_Now;
+
+ function Stop return Boolean is
+ begin
+ return Halt;
+ end Stop;
+ end Control;
+
+ task Pulse_Task; -- task to generate a pulse for each ramp
+
+ -- Carrier task. One is created for each vehicle arriving at the ramp
+ task type Vehicle;
+ type acc_Vehicle is access Vehicle;
+
+ --================================================================
+ protected Test_Ramp is
+ function Next_Ramp_in_Overload return Load_Factor;
+ function Local_Overload return Load_Factor;
+ function Freeway_Overload return Load_Factor;
+ function Freeway_Breakdown return Boolean;
+ function Meter_in_use_State return Boolean;
+ procedure Set_Local_Overload;
+ procedure Add_Meter_Queue;
+ procedure Subtract_Meter_Queue;
+ procedure Time_Pulse_Received;
+ entry Wait_at_Meter;
+ procedure TC_Passage (Pass_Point : Integer);
+ function TC_Get_Passage_Total return integer;
+ -- ::::::::: many routines are not shown (for example none of the
+ -- clears, none of the real-time-sensor handlers)
+
+ private
+
+ Release_One_Vehicle : Boolean := false;
+ Meter_in_Use : Boolean := false;
+ Fwy_Break_State : Boolean := false;
+
+
+ Ramp_Count : integer range 0..20 := 0;
+ Ramp_Count_Threshold : integer := 15;
+
+ -- Current state of the various Sample Points
+ Local_State : Load_Factor := Clear_Level;
+ Next_Ramp_State : Load_Factor := Clear_Level;
+ -- :::: other Sample Point states not shown
+
+ TC_Passage_Total : integer := 0;
+ end Test_Ramp;
+ --================================================================
+ protected body Test_Ramp is
+
+ procedure Start_Meter is
+ begin
+ Meter_in_Use := True;
+ null; -- stub :::: trigger the metering hardware
+ end Start_Meter;
+
+ -- External call for Meter_in_Use
+ function Meter_in_Use_State return Boolean is
+ begin
+ return Meter_in_Use;
+ end Meter_in_Use_State;
+
+ -- Trace the paths through the various routines by totaling the
+ -- weighted call parameters
+ procedure TC_Passage (Pass_Point : Integer) is
+ begin
+ TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
+ end TC_Passage;
+
+ -- For the final check of the whole test
+ function TC_Get_Passage_Total return integer is
+ begin
+ return TC_Passage_Total;
+ end TC_Get_Passage_Total;
+
+ -- These Set/Clear routines are triggered by real-time sensors that
+ -- reflect traffic state
+ procedure Set_Local_Overload is
+ begin
+ Local_State := Local_Overload_wt;
+ if not Meter_in_Use then
+ Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE
+ end if;
+ end Set_Local_Overload;
+
+ --::::: Set/Clear routines for all the other sensors not shown
+
+ function Local_Overload return Load_Factor is
+ begin
+ return Local_State;
+ end Local_Overload;
+
+ function Next_Ramp_in_Overload return Load_Factor is
+ begin
+ return Next_Ramp_State;
+ end Next_Ramp_in_Overload;
+
+ -- :::::::: other overload factor states not shown
+
+ -- return the summation of all the load factors
+ function Freeway_Overload return Load_Factor is
+ begin
+ return Local_Overload -- EACH IS A CALL OF A
+ -- + :::: others -- FUNCTION FROM WITHIN
+ + Next_Ramp_in_Overload; -- A FUNCTION
+ end Freeway_Overload;
+
+ -- Freeway Breakdown is defined as traffic moving < 5mph
+ function Freeway_Breakdown return Boolean is
+ begin
+ return Fwy_Break_State;
+ end Freeway_Breakdown;
+
+ -- Keep count of vehicles currently on meter queue - we can't use
+ -- the 'count because we need the outcall trigger
+ procedure Add_Meter_Queue is
+ TC_Pass_Point : constant integer := 22;
+ begin
+ Ramp_Count := Ramp_Count + 1;
+ TC_Passage ( TC_Pass_Point ); -- note passage through here
+ if Ramp_Count > Ramp_Count_Threshold then
+ null; -- :::: stub, trigger surface street notification
+ end if;
+ end Add_Meter_Queue;
+ --
+ procedure Subtract_Meter_Queue is
+ TC_Pass_Point : constant integer := 24;
+ begin
+ Ramp_Count := Ramp_Count - 1;
+ TC_Passage ( TC_Pass_Point ); -- note passage through here
+ end Subtract_Meter_Queue;
+
+ -- Here each Vehicle task queues itself awaiting release
+ entry Wait_at_Meter when Release_One_Vehicle is
+ -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
+ TC_Pass_Point : constant integer := 23;
+ begin
+ TC_Passage ( TC_Pass_Point ); -- note passage through here
+ Release_One_Vehicle := false; -- Consume the signal
+ -- Decrement number of vehicles on ramp
+ Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY
+ end Wait_at_Meter;
+
+
+ procedure Time_Pulse_Received is
+ Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL
+ -- FUNCTION
+ -- FROM WITHIN PROCEDURE
+ begin
+ -- if broken down, no vehicles are released
+ if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE
+ if Load < Moderate_Level then
+ Release_One_Vehicle := true;
+ end if;
+ null; -- stub ::: If other levels, release every other
+ -- pulse, every third pulse etc.
+ end if;
+ end Time_Pulse_Received;
+
+ end Test_Ramp;
+ --================================================================
+
+
+ -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
+ -- generation of an accompanying carrier task
+ procedure New_Arrival is
+ Next_Vehicle_Task: acc_Vehicle := new Vehicle;
+ TC_Pass_Point : constant integer := 3;
+ begin
+ Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here
+ null;
+ end New_arrival;
+
+
+ -- Carrier task. One is created for each vehicle arriving at the ramp
+ task body Vehicle is
+ TC_Pass_point : constant integer := 1;
+ TC_Pass_Point_2 : constant integer := 21;
+ TC_Pass_Point_3 : constant integer := 2;
+ begin
+ Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage through here
+ if Test_Ramp.Meter_in_Use_State then
+ Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage
+ -- Increment count of number of vehicles on ramp
+ Test_Ramp.Add_Meter_Queue; -- CALL a protected PROCEDURE
+ -- which is also called from within
+ -- enter the meter queue
+ Test_Ramp.Wait_at_Meter; -- CALL a protected ENTRY
+ end if;
+ Test_Ramp.TC_Passage ( TC_Pass_Point_3 ); -- note passage thru here
+ null; --:::: call to the first in the series of the Ramp_Sensors
+ -- this "passes" the vehicle from one sensor to the next
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Vehicle Task");
+ end Vehicle;
+
+
+ -- Task transmits a synchronizing "pulse" to all ramps
+ --
+ task body Pulse_Task is
+ Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
+ begin
+ While not Control.Stop loop
+ delay until Pulse_Time;
+ Test_Ramp.Time_Pulse_Received; -- causes INTERNAL CALLS
+ -- :::::::::: and to all the others
+ Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Pulse_Task");
+ end Pulse_Task;
+
+
+ begin -- declare
+
+ -- Test driver. This is ALL test control code
+
+ -- First simulate calls to the protected functions and procedures
+ -- from without the protected object
+ --
+ -- CALL FUNCTIONS
+ if Test_Ramp.Local_Overload /= Clear_Level then
+ Report.Failed ("External Call to Local_Overload incorrect");
+ end if;
+ if Test_Ramp.Next_Ramp_in_Overload /= Clear_Level then
+ Report.Failed ("External Call to Next_Ramp_in_Overload incorrect");
+ end if;
+ if Test_Ramp.Freeway_Overload /= Clear_Level then
+ Report.Failed ("External Call to Freeway_Overload incorrect");
+ end if;
+
+ -- Now Simulate the arrival of a vehicle to verify path through test
+ New_Arrival;
+ delay Pulse_Time_Delta*2; -- allow it to pass through the complex
+
+ TC_Multiplier := 5; -- change the weights for the paths for the next
+ -- part of the test
+
+ -- Simulate a real-time sensor reporting overload
+ Test_Ramp.Set_Local_Overload; -- CALL A PROCEDURE (and change levels)
+
+ -- CALL FUNCTIONS again
+ if Test_Ramp.Local_Overload /= Minimum_Level then
+ Report.Failed ("External Call to Local_Overload incorrect - 2");
+ end if;
+ if Test_Ramp.Freeway_Overload /= Minimum_Level then
+ Report.Failed ("External Call to Freeway_Overload incorrect -2");
+ end if;
+
+ -- Now Simulate the arrival of another vehicle again causing
+ -- INTERNAL CALLS but following different paths (queuing on the
+ -- meter etc.)
+ New_Arrival;
+ delay Pulse_Time_Delta*2; -- allow it to pass through the complex
+
+ Control.Stop_Now; -- finish test
+
+ if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then
+ Report.Failed ("Unexpected paths taken");
+ end if;
+
+ end; -- declare
+
+ Report.Result;
+
+end C940005;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940006.a b/gcc/testsuite/ada/acats/tests/c9/c940006.a
new file mode 100644
index 000000000..36e6c9171
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940006.a
@@ -0,0 +1,223 @@
+-- C940006.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the body of a protected function can have external calls
+-- to other protected functions and that the body of a protected
+-- procedure can have external calls to protected procedures and to
+-- protected functions.
+--
+-- TEST DESCRIPTION:
+-- Use a subset of the simulation of the freeway on-ramp described in
+-- c940005. In this case two protected objects are used but only a
+-- minimum of routines are shown in each. Both objects are hard coded
+-- and detail two adjacent on-ramps (Ramp_31 & Ramp_32) with routines in
+-- each which use external calls to the other.
+
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+
+procedure C940006 is
+
+begin
+
+ Report.Test ("C940006", "Check external calls of protected functions" &
+ " and procedures");
+
+ declare -- encapsulate the test
+
+ -- Weighted load given to each potential problem area and accumulated
+ type Load_Factor is range 0..8;
+ --
+ Clear_Level : constant Load_Factor := 0;
+ Minimum_Level : constant Load_Factor := 1;
+ Moderate_Level : constant Load_Factor := 3;
+ Serious_Level : constant Load_Factor := 4;
+ Critical_Level : constant Load_Factor := 6;
+
+ --================================================================
+ -- Only the Routines that are used in this test are shown
+ --
+ protected Ramp_31 is
+
+ function Local_Overload return Load_Factor;
+ procedure Set_Local_Overload(Sensor_Level : Load_Factor);
+ procedure Notify;
+ function Next_Ramp_Overload return Load_Factor;
+ function Freeway_Overload return Load_Factor;
+ procedure Downstream_Ramps;
+ function Get_DSR_Accumulate return Load_Factor;
+
+ private
+ Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble?
+
+ -- Current state of the various Sample Points
+ Local_State : Load_Factor := Clear_Level;
+ -- Accumulated load for next three downstream ramps
+ DSR_Accumulate : Load_Factor := Clear_Level;
+
+ end Ramp_31;
+ --================================================================
+ -- Only the Routines that are used in this test are shown
+ --
+ protected Ramp_32 is
+
+ function Local_Overload return Load_Factor;
+ procedure Set_Local_Overload (Sensor_Level : Load_Factor);
+
+ private
+
+ Local_State : Load_Factor := Clear_Level;
+
+ end Ramp_32;
+ --================================================================
+ protected body Ramp_31 is
+
+ -- These Set/Clear routines are triggered by real-time sensors that
+ -- reflect traffic state
+ procedure Set_Local_Overload (Sensor_Level : Load_Factor) is
+ begin
+ -- Notify "previous" ramp to check this one for current state.
+ -- Subsequent changes in state will not send an alert
+ null; --::::: (see Ramp_32 for this code)
+ Local_State := Sensor_Level;
+ null; --::::: Start local meter if not already started
+ end Set_Local_Overload;
+
+ function Local_Overload return Load_Factor is
+ begin
+ return Local_State;
+ end Local_Overload;
+
+ -- This is notification from the next ramp that it is in
+ -- overload. With this provision we only need to sample the next
+ -- ramp during adverse conditions.
+ procedure Notify is
+ begin
+ Next_Ramp_Alert := true;
+ end Notify;
+
+ function Next_Ramp_Overload return Load_Factor is
+ begin
+ if Next_Ramp_Alert then
+ -- EXTERNAL FUNCTION CALL FROM FUNCTION
+ -- Get next ramp's current state
+ return Ramp_32.Local_Overload;
+ else
+ return Clear_Level;
+ end if;
+ end Next_Ramp_Overload;
+
+ -- return the summation of all the load factors
+ function Freeway_Overload return Load_Factor is
+ begin
+ return Local_Overload
+ -- + :::: others
+ + Next_Ramp_Overload;
+ end Freeway_Overload;
+
+ -- Snapshot the states of the next three downstream ramps
+ procedure Downstream_Ramps is
+ begin
+ DSR_Accumulate := Ramp_32.Local_Overload; -- EXTERNAL FUNCTION
+ -- :::: + Ramp_33.Local_Overload -- FROM PROCEDURE
+ -- :::: + Ramp_34.Local_Overload
+ end Downstream_Ramps;
+
+ -- Get last snapshot
+ function Get_DSR_Accumulate return Load_Factor is
+ begin
+ return DSR_Accumulate;
+ end Get_DSR_Accumulate;
+
+ end Ramp_31;
+ --================================================================
+ protected body Ramp_32 is
+
+ function Local_Overload return Load_Factor is
+ begin
+ return Local_State;
+ end;
+
+
+ -- These Set/Clear routines are triggered by real-time sensors that
+ -- reflect traffic state
+ procedure Set_Local_Overload(Sensor_Level : Load_Factor) is
+ begin
+ if Local_State = Clear_Level then
+ -- Notify "previous" ramp to check this one for current state.
+ -- Subsequent changes in state will not send an alert
+ -- When the situation clears another routine performs the
+ -- all_clear notification. (not shown)
+ -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE
+ Ramp_31.Notify;
+ end if;
+ Local_State := Sensor_Level;
+ null; --::::: Start local meter if not already started
+ end;
+
+ end Ramp_32;
+ --================================================================
+
+
+
+ begin -- declare
+
+ -- Test driver. This is ALL test control code
+ -- Simulate calls to the protected functions and procedures
+ -- from without the protected object, these will, in turn make the
+ -- external calls.
+
+ -- Check initial conditions, exercising the simple calls
+ if not (Ramp_31.Local_Overload = Clear_Level and
+ Ramp_31.Next_Ramp_Overload = Clear_Level and
+ Ramp_31.Freeway_Overload = Clear_Level) and
+ Ramp_32.Local_Overload = Clear_Level then
+ Report.Failed ("Initial Calls provided unexpected Results");
+ end if;
+
+ -- Simulate real-time sensors reporting overloads at a hardware level
+ Ramp_31.Set_Local_Overload (1);
+ Ramp_32.Set_Local_Overload (3);
+
+ Ramp_31.Downstream_Ramps; -- take the current snapshot
+
+ if not (Ramp_31.Local_Overload = Minimum_Level and
+ Ramp_31.Get_DSR_Accumulate = Moderate_Level and
+ Ramp_31.Freeway_Overload = Serious_Level) then
+ Report.Failed ("Secondary Calls provided unexpected Results");
+ end if;
+
+ end; -- declare
+
+ Report.Result;
+
+end C940006;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940007.a b/gcc/testsuite/ada/acats/tests/c9/c940007.a
new file mode 100644
index 000000000..41e80f4e2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940007.a
@@ -0,0 +1,427 @@
+-- C940007.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the body of a protected function declared as an object of a
+-- given type can have internal calls to other protected functions and
+-- that a protected procedure in such an object can have internal calls
+-- to protected procedures and to protected functions.
+--
+-- TEST DESCRIPTION:
+-- Simulate a meter at a freeway on-ramp which, when real-time sensors
+-- determine that the freeway is becoming saturated, triggers stop lights
+-- which control the access of vehicles to prevent further saturation.
+-- Each on-ramp is represented by a protected object of the type Ramp.
+-- The routines to sample and alter the states of the various sensors, to
+-- queue the vehicles on the meter and to release them are all part of
+-- the protected object and can be shared by various tasks. Apart from
+-- the function/procedure tests this example has a mix of other tasking
+-- features. In this test two objects representing two adjacent ramps
+-- are created from the same type. The same "traffic" is simulated for
+-- each ramp. The results should be identical.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 13 Nov 95 SAIC Replaced shared global variable Pulse_Stop
+-- with a protected object.
+-- ACVC 2.0.1
+--
+--!
+
+
+with Report;
+with ImpDef;
+with Ada.Calendar;
+
+
+procedure C940007 is
+
+begin
+
+ Report.Test ("C940007", "Check internal calls of protected functions" &
+ " and procedures in objects declared as a type");
+
+ declare -- encapsulate the test
+
+ function "+" (Left : Ada.Calendar.Time; Right: Duration)
+ return Ada.Calendar.Time renames Ada.Calendar."+";
+
+ -- Weighted load given to each potential problem area and accumulated
+ type Load_Factor is range 0..8;
+ Clear_Level : constant Load_Factor := 0;
+ Minimum_Level : constant Load_Factor := 1;
+ Moderate_Level : constant Load_Factor := 2;
+ Serious_Level : constant Load_Factor := 4;
+ Critical_Level : constant Load_Factor := 6;
+
+ -- Weighted loads given to each Sample Point (pure weights, not levels)
+ Local_Overload_wt : constant Load_Factor := 1;
+ Next_Ramp_in_Overload_wt : constant Load_Factor := 1;
+ Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght
+ -- :::: other weighted loads
+
+ TC_Expected_Passage_Total : integer := 486;
+
+
+ -- This is the time between synchronizing pulses to the ramps.
+ -- In reality one would expect a time of 5 to 10 seconds. In
+ -- the interests of speeding up the test suite a shorter time
+ -- is used
+ Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task;
+
+
+ -- control over stopping tasks
+ protected Control is
+ procedure Stop_Now;
+ function Stop return Boolean;
+ private
+ Halt : Boolean := False;
+ end Control;
+
+ protected body Control is
+ procedure Stop_Now is
+ begin
+ Halt := True;
+ end Stop_Now;
+
+ function Stop return Boolean is
+ begin
+ return Halt;
+ end Stop;
+ end Control;
+
+
+ task Pulse_Task; -- task to generate a pulse for each ramp
+
+ -- Carrier tasks. One is created for each vehicle arriving at each ramp
+ task type Vehicle_31; -- For Ramp_31
+ type acc_Vehicle_31 is access Vehicle_31;
+ --
+ task type Vehicle_32; -- For Ramp_32
+ type acc_Vehicle_32 is access Vehicle_32;
+
+ --================================================================
+ protected type Ramp is
+ function Next_Ramp_in_Overload return Load_Factor;
+ function Local_Overload return Load_Factor;
+ function Freeway_Overload return Load_Factor;
+ function Freeway_Breakdown return Boolean;
+ function Meter_in_Use_State return Boolean;
+ procedure Set_Local_Overload;
+ procedure Add_Meter_Queue;
+ procedure Subtract_Meter_Queue;
+ procedure Time_Pulse_Received;
+ entry Wait_at_Meter;
+ procedure TC_Passage (Pass_Point : Integer);
+ function TC_Get_Passage_Total return integer;
+ -- ::::::::: many routines are not shown (for example none of the
+ -- clears, none of the real-time-sensor handlers)
+
+ private
+
+ Release_One_Vehicle : Boolean := false;
+ Meter_in_Use : Boolean := false;
+ Fwy_Break_State : Boolean := false;
+
+
+ Ramp_Count : integer range 0..20 := 0;
+ Ramp_Count_Threshold : integer := 15;
+
+ -- Current state of the various Sample Points
+ Local_State : Load_Factor := Clear_Level;
+ Next_Ramp_State : Load_Factor := Clear_Level;
+ -- :::: other Sample Point states not shown
+
+ TC_Multiplier : integer := 1; -- changed half way through
+ TC_Passage_Total : integer := 0;
+ end Ramp;
+ --================================================================
+ protected body Ramp is
+
+ procedure Start_Meter is
+ begin
+ Meter_in_Use := True;
+ null; -- stub :::: trigger the metering hardware
+ end Start_Meter;
+
+ function Meter_in_Use_State return Boolean is
+ begin
+ return Meter_in_Use;
+ end Meter_in_Use_State;
+
+ -- Trace the paths through the various routines by totaling the
+ -- weighted call parameters
+ procedure TC_Passage (Pass_Point : Integer) is
+ begin
+ TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
+ end TC_Passage;
+
+ -- For the final check of the whole test
+ function TC_Get_Passage_Total return integer is
+ begin
+ return TC_Passage_Total;
+ end TC_Get_Passage_Total;
+
+ -- These Set/Clear routines are triggered by real-time sensors that
+ -- reflect traffic state
+ procedure Set_Local_Overload is
+ begin
+ Local_State := Local_Overload_wt;
+ if not Meter_in_Use then
+ Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE
+ end if;
+ -- Change the weights for the paths for the next part of the test
+ TC_Multiplier :=5;
+ end Set_Local_Overload;
+
+ --::::: Set/Clear routines for all the other sensors not shown
+
+ function Local_Overload return Load_Factor is
+ begin
+ return Local_State;
+ end Local_Overload;
+
+ function Next_Ramp_in_Overload return Load_Factor is
+ begin
+ return Next_Ramp_State;
+ end Next_Ramp_in_Overload;
+
+ -- :::::::: other overload factor states not shown
+
+ -- return the summation of all the load factors
+ function Freeway_Overload return Load_Factor is
+ begin
+ return Local_Overload -- EACH IS A CALL OF A
+ -- + :::: others -- FUNCTION FROM WITHIN
+ + Next_Ramp_in_Overload; -- A FUNCTION
+ end Freeway_Overload;
+
+ -- Freeway Breakdown is defined as traffic moving < 5mph
+ function Freeway_Breakdown return Boolean is
+ begin
+ return Fwy_Break_State;
+ end Freeway_Breakdown;
+
+ -- Keep count of vehicles currently on meter queue - we can't use
+ -- the 'count because we need the outcall trigger
+ procedure Add_Meter_Queue is
+ TC_Pass_Point : constant integer := 22;
+ begin
+ Ramp_Count := Ramp_Count + 1;
+ TC_Passage ( TC_Pass_Point ); -- note passage through here
+ if Ramp_Count > Ramp_Count_Threshold then
+ null; -- :::: stub, trigger surface street notification
+ end if;
+ end Add_Meter_Queue;
+ --
+ procedure Subtract_Meter_Queue is
+ TC_Pass_Point : constant integer := 24;
+ begin
+ Ramp_Count := Ramp_Count - 1;
+ TC_Passage ( TC_Pass_Point ); -- note passage through here
+ end Subtract_Meter_Queue;
+
+ -- Here each Vehicle task queues itself awaiting release
+ entry Wait_at_Meter when Release_One_Vehicle is
+ -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
+ TC_Pass_Point : constant integer := 23;
+ begin
+ TC_Passage ( TC_Pass_Point ); -- note passage through here
+ Release_One_Vehicle := false; -- Consume the signal
+ -- Decrement number of vehicles on ramp
+ Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY
+ end Wait_at_Meter;
+
+
+ procedure Time_Pulse_Received is
+ Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL FUNCTN
+ -- FROM WITHIN PROCEDURE
+ begin
+ -- if broken down, no vehicles are released
+ if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE
+ if Load < Moderate_Level then
+ Release_One_Vehicle := true;
+ end if;
+ null; -- stub ::: If other levels, release every other
+ -- pulse, every third pulse etc.
+ end if;
+ end Time_Pulse_Received;
+
+ end Ramp;
+ --================================================================
+
+ -- Now create two Ramp objects from this type
+ Ramp_31 : Ramp;
+ Ramp_32 : Ramp;
+
+
+
+ -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31
+ -- and the generation of an accompanying carrier task
+ procedure New_Arrival_31 is
+ Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31;
+ TC_Pass_Point : constant integer := 3;
+ begin
+ Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here
+ null; --::: stub
+ end New_arrival_31;
+
+
+ -- Carrier task. One is created for each vehicle arriving at Ramp_31
+ task body Vehicle_31 is
+ TC_Pass_point : constant integer := 1;
+ TC_Pass_Point_2 : constant integer := 21;
+ TC_Pass_Point_3 : constant integer := 2;
+ begin
+ Ramp_31.TC_Passage ( TC_Pass_Point ); -- note passage through here
+ if Ramp_31.Meter_in_Use_State then
+ Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage
+ -- Increment count of number of vehicles on ramp
+ Ramp_31.Add_Meter_Queue; -- CALL a protected PROCEDURE
+ -- which is also called from within
+ -- enter the meter queue
+ Ramp_31.Wait_at_Meter; -- CALL a protected ENTRY
+ end if;
+ Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here
+ null; --:::: call to the first in the series of the Ramp_Sensors
+ -- this "passes" the vehicle from one sensor to the next
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Vehicle Task");
+ end Vehicle_31;
+
+
+ -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
+ -- generation of an accompanying carrier task
+ procedure New_Arrival_32 is
+ Next_Vehicle_Task_32 : acc_Vehicle_32 := new Vehicle_32;
+ TC_Pass_Point : constant integer := 3;
+ begin
+ Ramp_32.TC_Passage ( TC_Pass_Point ); -- Note passage through here
+ null; --::: stub
+ end New_arrival_32;
+
+
+ -- Carrier task. One is created for each vehicle arriving at Ramp_32
+ task body Vehicle_32 is
+ TC_Pass_point : constant integer := 1;
+ TC_Pass_Point_2 : constant integer := 21;
+ TC_Pass_Point_3 : constant integer := 2;
+ begin
+ Ramp_32.TC_Passage ( TC_Pass_Point ); -- note passage through here
+ if Ramp_32.Meter_in_Use_State then
+ Ramp_32.TC_Passage ( TC_Pass_Point_2 ); -- note passage
+ -- Increment count of number of vehicles on ramp
+ Ramp_32.Add_Meter_Queue; -- CALL a protected PROCEDURE
+ -- which is also called from within
+ -- enter the meter queue
+ Ramp_32.Wait_at_Meter; -- CALL a protected ENTRY
+ end if;
+ Ramp_32.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here
+ null; --:::: call to the first in the series of the Ramp_Sensors
+ -- this "passes" the vehicle from one sensor to the next
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Vehicle Task");
+ end Vehicle_32;
+
+
+ -- Task transmits a synchronizing "pulse" to all ramps
+ --
+ task body Pulse_Task is
+ Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
+ begin
+ While not Control.Stop loop
+ delay until Pulse_Time;
+ Ramp_31.Time_Pulse_Received; -- CALL OF PROCEDURE CAUSES
+ Ramp_32.Time_Pulse_Received; -- INTERNAL CALLS
+ -- :::::::::: and to all the others
+ Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Pulse_Task");
+ end Pulse_Task;
+
+
+ begin -- declare
+
+ -- Test driver. This is ALL test control code
+
+ -- First simulate calls to the protected functions and procedures
+ -- from without the protected object
+ --
+ -- CALL FUNCTIONS
+ if not ( Ramp_31.Local_Overload = Clear_Level and
+ Ramp_31.Next_Ramp_in_Overload = Clear_Level and
+ Ramp_31.Freeway_Overload = Clear_Level ) then
+ Report.Failed ("Initial Calls to Ramp_31 incorrect");
+ end if;
+ if not ( Ramp_32.Local_Overload = Clear_Level and
+ Ramp_32.Next_Ramp_in_Overload = Clear_Level and
+ Ramp_32.Freeway_Overload = Clear_Level ) then
+ Report.Failed ("Initial Calls to Ramp_32 incorrect");
+ end if;
+
+ -- Now Simulate the arrival of a vehicle at each ramp to verify
+ -- basic paths through the test
+ New_Arrival_31;
+ New_Arrival_32;
+ delay Pulse_Time_Delta*2; -- allow them to pass through the complex
+
+ -- Simulate real-time sensors reporting overload
+ Ramp_31.Set_Local_Overload; -- CALL A PROCEDURE (and change levels)
+ Ramp_32.Set_Local_Overload; -- CALL A PROCEDURE (and change levels)
+
+ -- CALL FUNCTIONS again
+ if not ( Ramp_31.Local_Overload = Minimum_Level and
+ Ramp_31.Freeway_Overload = Minimum_Level ) then
+ Report.Failed ("Secondary Calls to Ramp_31 incorrect");
+ end if;
+ if not ( Ramp_32.Local_Overload = Minimum_Level and
+ Ramp_32.Freeway_Overload = Minimum_Level ) then
+ Report.Failed ("Secondary Calls to Ramp_32 incorrect");
+ end if;
+
+ -- Now Simulate the arrival of another vehicle at each ramp again causing
+ -- INTERNAL CALLS but following different paths (queuing on the
+ -- meter etc.)
+ New_Arrival_31;
+ New_Arrival_32;
+ delay Pulse_Time_Delta*2; -- allow them to pass through the complex
+
+ Control.Stop_Now; -- finish test
+
+ if not (TC_Expected_Passage_Total = Ramp_31.TC_Get_Passage_Total and
+ TC_Expected_Passage_Total = Ramp_32.TC_Get_Passage_Total) then
+ Report.Failed ("Unexpected paths taken");
+ end if;
+
+ end; -- declare
+
+ Report.Result;
+
+end C940007;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940010.a b/gcc/testsuite/ada/acats/tests/c9/c940010.a
new file mode 100644
index 000000000..c4a670552
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940010.a
@@ -0,0 +1,269 @@
+-- C940010.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if an exception is raised during the execution of an
+-- entry body it is propagated back to the caller
+--
+-- TEST DESCRIPTION:
+-- Use a small fragment of code from the simulation of a freeway meter
+-- used in c940007. Create three individual tasks which will be queued on
+-- the entry as the barrier is set. Release them one at a time. A
+-- procedure which is called within the entry has been modified for this
+-- test to raise a different exception for each pass through. Check that
+-- all expected exceptions are raised and propagated.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+with ImpDef;
+
+procedure C940010 is
+
+ TC_Failed_1 : Boolean := false;
+
+begin
+
+ Report.Test ("C940010", "Check that an exception raised in an entry " &
+ "body is propagated back to the caller");
+
+ declare -- encapsulate the test
+
+ TC_Defined_Error : Exception; -- User defined exception
+ TC_Expected_Passage_Total : constant integer := 669;
+ TC_Int : constant integer := 5;
+
+ -- Carrier tasks. One is created for each vehicle arriving at each ramp
+ task type Vehicle_31; -- For Ramp_31
+ type acc_Vehicle_31 is access Vehicle_31;
+
+
+ --================================================================
+ protected Ramp_31 is
+
+ function Meter_in_Use_State return Boolean;
+ procedure Add_Meter_Queue;
+ procedure Subtract_Meter_Queue;
+ entry Wait_at_Meter;
+ procedure Pulse;
+ --
+ procedure TC_Passage (Pass_Point : Integer);
+ function TC_Get_Passage_Total return integer;
+ function TC_Get_Current_Exception return integer;
+
+ private
+
+ Release_One_Vehicle : Boolean := false;
+ Meter_in_Use : Boolean := true; -- TC: set true for this test
+ --
+ TC_Multiplier : integer := 1;
+ TC_Passage_Total : integer := 0;
+ -- Use this to cycle through the required exceptions
+ TC_Current_Exception : integer range 0..3 := 0;
+
+ end Ramp_31;
+ --================================================================
+ protected body Ramp_31 is
+
+
+ -- Trace the paths through the various routines by totaling the
+ -- weighted call parameters
+ procedure TC_Passage (Pass_Point : Integer) is
+ begin
+ TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
+ end TC_Passage;
+
+ -- For the final check of the whole test
+ function TC_Get_Passage_Total return integer is
+ begin
+ return TC_Passage_Total;
+ end TC_Get_Passage_Total;
+
+ function TC_Get_Current_Exception return integer is
+ begin
+ return TC_Current_Exception;
+ end TC_Get_Current_Exception;
+
+
+ -----------------
+
+ function Meter_in_Use_State return Boolean is
+ begin
+ return Meter_in_Use;
+ end Meter_in_Use_State;
+
+ -- Simulate the effects of the regular signal pulse
+ procedure Pulse is
+ begin
+ Release_one_Vehicle := true;
+ end Pulse;
+
+ -- Keep count of vehicles currently on meter queue - we can't use
+ -- the 'count because we need the outcall trigger
+ procedure Add_Meter_Queue is
+ begin
+ null; --::: stub
+ end Add_Meter_Queue;
+
+ -- TC: This routine has been modified to raise the required
+ -- exceptions
+ procedure Subtract_Meter_Queue is
+ TC_Pass_Point1 : constant integer := 10;
+ TC_Pass_Point2 : constant integer := 20;
+ TC_Pass_Point3 : constant integer := 30;
+ TC_Pass_Point9 : constant integer := 1000; -- error
+ begin
+ -- Cycle through the required exceptions, one per call
+ TC_Current_Exception := TC_Current_Exception + 1;
+ case TC_Current_Exception is
+ when 1 =>
+ TC_Passage (TC_Pass_Point1); -- note passage through here
+ raise Storage_Error; -- PREDEFINED EXCEPTION
+ when 2 =>
+ TC_Passage (TC_Pass_Point2); -- note passage through here
+ raise TC_Defined_Error; -- USER DEFINED EXCEPTION
+ when 3 =>
+ TC_Passage (TC_Pass_Point3); -- note passage through here
+ -- RUN TIME EXCEPTION (Constraint_Error)
+ -- Add the value 3 to 5 then try to assign it to an object
+ -- whose range is 0..3 - this causes the exception.
+ -- Disguise the values which cause the Constraint_Error
+ -- so that the optimizer will not eliminate this code
+ -- Note: the variable is checked at the end to ensure
+ -- that the actual assignment is attempted. Also note
+ -- the value remains at 3 as the assignment does not
+ -- take place. This is the value that is checked at
+ -- the end of the test.
+ -- Otherwise the optimizer could decide that the result
+ -- of the assignment was not used so why bother to do it?
+ TC_Current_Exception :=
+ Report.Ident_Int (TC_Current_Exception) +
+ Report.Ident_Int (TC_Int);
+ when others =>
+ -- Set flag for Report.Failed which cannot be called from
+ -- within a Protected Object
+ TC_Failed_1 := True;
+ end case;
+
+ TC_Passage ( TC_Pass_Point9 ); -- note passage through here
+ end Subtract_Meter_Queue;
+
+ -- Here each Vehicle task queues itself awaiting release
+ entry Wait_at_Meter when Release_One_Vehicle is
+ -- Example of entry with barriers and persistent signal
+ TC_Pass_Point : constant integer := 2;
+ begin
+ TC_Passage ( TC_Pass_Point ); -- note passage through here
+ Release_One_Vehicle := false; -- Consume the signal
+ -- Decrement number of vehicles on ramp
+ Subtract_Meter_Queue; -- Call procedure from within entry body
+ end Wait_at_Meter;
+
+ end Ramp_31;
+ --================================================================
+
+ -- Carrier task. One is created for each vehicle arriving at Ramp_31
+ task body Vehicle_31 is
+ TC_Pass_Point_1 : constant integer := 100;
+ TC_Pass_Point_2 : constant integer := 200;
+ TC_Pass_Point_3 : constant integer := 300;
+ begin
+ if Ramp_31.Meter_in_Use_State then
+ -- Increment count of number of vehicles on ramp
+ Ramp_31.Add_Meter_Queue; -- Call a protected procedure
+ -- which is also called from within
+ -- enter the meter queue
+ Ramp_31.Wait_at_Meter; -- Call a protected entry
+ Report.Failed ("Exception not propagated back");
+ end if;
+ null; --:::: call to the first in the series of the Ramp_Sensors
+ -- this "passes" the vehicle from one sensor to the next
+ exception
+ when Storage_Error =>
+ Ramp_31.TC_Passage ( TC_Pass_Point_1 ); -- note passage
+ when TC_Defined_Error =>
+ Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage
+ when Constraint_Error =>
+ Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage
+ when others =>
+ Report.Failed ("Unexpected exception in Vehicle Task");
+ end Vehicle_31;
+
+ -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31
+ -- and the generation of an accompanying carrier task
+ procedure New_Arrival_31 is
+ Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31;
+ TC_Pass_Point : constant integer := 1;
+ begin
+ Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here
+ null; --::: stub
+ end New_arrival_31;
+
+
+
+ begin -- declare
+
+ -- Test driver. This is ALL test control code
+
+ -- Create three independent tasks which will queue themselves on the
+ -- entry. Each task will get a different exception
+ New_Arrival_31;
+ New_Arrival_31;
+ New_Arrival_31;
+
+ delay ImpDef.Clear_Ready_Queue;
+
+ -- Set the barrier condition of the entry true, releasing one task
+ Ramp_31.Pulse;
+ delay ImpDef.Clear_Ready_Queue;
+
+ Ramp_31.Pulse;
+ delay ImpDef.Clear_Ready_Queue;
+
+ Ramp_31.Pulse;
+ delay ImpDef.Clear_Ready_Queue;
+
+ if (TC_Expected_Passage_Total /= Ramp_31.TC_Get_Passage_Total) or
+ -- Note: We are not really interested in this next check. It is
+ -- here to ensure the earlier statements which raised the
+ -- Constraint_Error are not optimized out
+ (Ramp_31.TC_Get_Current_Exception /= 3) then
+ Report.Failed ("Unexpected paths taken");
+ end if;
+
+ end; -- declare
+
+ if TC_Failed_1 then
+ Report.Failed ("Bad path through Subtract_Meter_Queue");
+ end if;
+
+ Report.Result;
+
+end C940010;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940011.a b/gcc/testsuite/ada/acats/tests/c9/c940011.a
new file mode 100644
index 000000000..65228666c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940011.a
@@ -0,0 +1,175 @@
+-- C940011.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that, in the body of a protected object created by the execution
+-- of an allocator, external calls to other protected objects via
+-- the access type are correctly performed
+--
+-- TEST DESCRIPTION:
+-- Use a subset of the simulation of the freeway on-ramp described in
+-- c940005. In this case an array of access types is built with pointers
+-- to successive ramps. The external calls within the protected
+-- objects are made via the index into the array. Routines which refer
+-- to the "previous" ramp and the "next" ramp are exercised. (Note: The
+-- first and last ramps are assumed to be dummies and no first/last
+-- condition code is included)
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+
+
+procedure C940011 is
+
+ type Ramp;
+ type acc_Ramp is access Ramp;
+
+ subtype Ramp_Index is integer range 1..4;
+
+
+ -- Weighted load given to each potential problem area and accumulated
+ type Load_Factor is range 0..8;
+ Clear_Level : constant Load_Factor := 0;
+ Moderate_Level : constant Load_Factor := 3;
+
+ --================================================================
+ -- Only the Routines that are used in this test are shown
+ --
+ protected type Ramp is
+
+ procedure Set_Index (Index : Ramp_Index);
+ procedure Set_Local_Overload (Sensor_Level : Load_Factor);
+ function Local_Overload return Load_Factor;
+ procedure Notify;
+ function Next_Ramp_Overload return Load_Factor;
+
+ private
+
+ This_Ramp : Ramp_Index;
+
+ Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble?
+
+ -- Current state of the various Sample Points
+ Local_State : Load_Factor := Clear_Level;
+
+ end Ramp;
+ --================================================================
+
+ -- Build a set of Ramp objects and an array of pointers to them
+ --
+ Ramp_Array : array (Ramp_Index) of acc_Ramp := (Ramp_Index => new Ramp);
+
+ --================================================================
+ protected body Ramp is
+
+ procedure Set_Index (Index : Ramp_Index) is
+ begin
+ This_Ramp := Index;
+ end Set_Index;
+
+ -- These Set/Clear routines are triggered by real-time sensors that
+ -- reflect traffic state
+ procedure Set_Local_Overload(Sensor_Level : Load_Factor) is
+ begin
+ if Local_State = Clear_Level then
+ -- Notify "previous" ramp to check this one for current state.
+ -- Subsequent changes in state will not send an alert
+ -- When the situation clears another routine performs the
+ -- all_clear notification. (not shown)
+ -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE
+ Ramp_Array(This_Ramp - 1).Notify; -- index to previous ramp
+ end if;
+ Local_State := Sensor_Level;
+ null; --::::: Start local meter if not already started
+ end Set_Local_Overload;
+
+ function Local_Overload return Load_Factor is
+ begin
+ return Local_State;
+ end Local_Overload;
+
+ -- This is notification from the next ramp that it is in
+ -- overload. With this provision we only need to sample the next
+ -- ramp during adverse conditions.
+ procedure Notify is
+ begin
+ Next_Ramp_Alert := true;
+ end Notify;
+
+ function Next_Ramp_Overload return Load_Factor is
+ begin
+ if Next_Ramp_Alert then
+ -- EXTERNAL FUNCTION CALL FROM FUNCTION
+ -- Get next ramp's current state
+ return Ramp_Array(This_Ramp + 1).Local_Overload;
+ else
+ return Clear_Level;
+ end if;
+ end Next_Ramp_Overload;
+ end Ramp;
+
+ --================================================================
+
+
+begin
+
+
+ Report.Test ("C940011", "Protected Objects created by allocators: " &
+ "external calls via access types");
+
+ -- Initialize each Ramp
+ for i in Ramp_Index loop
+ Ramp_Array(i).Set_Index (i);
+ end loop;
+
+ -- Test driver. This is ALL test control code
+
+ -- Simulate calls to the protected functions and procedures
+ -- external calls. (do not call the "dummy" end ramps)
+
+ -- Simple Call
+ if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then
+ Report.Failed ("Primary call incorrect");
+ end if;
+
+ -- Call which results in an external procedure call via the array
+ -- index from within the protected object
+ Ramp_Array(3).Set_Local_Overload (Moderate_Level);
+
+ -- Call which results in an external function call via the array
+ -- index from within the protected object
+ if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then
+ Report.Failed ("Secondary call incorrect");
+ end if;
+
+ Report.Result;
+
+end C940011;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940012.a b/gcc/testsuite/ada/acats/tests/c9/c940012.a
new file mode 100644
index 000000000..d4bd2079c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940012.a
@@ -0,0 +1,174 @@
+-- C940012.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a protected object can have discriminants
+--
+-- TEST DESCRIPTION:
+-- Use a subset of the simulation of the freeway on-ramp described in
+-- c940005. In this case an array of access types is built with pointers
+-- to successive ramps. Each ramp has its Ramp_Number specified by
+-- discriminant and this corresponds to the index in the array. The test
+-- checks that the ramp numbers are assigned as expected then uses calls
+-- to procedures within the objects (ramps) to verify external calls to
+-- ensure the structures are valid. The external references within the
+-- protected objects are made via the index into the array. Routines
+-- which refer to the "previous" ramp and the "next" ramp are exercised.
+-- (Note: The first and last ramps are assumed to be dummies and no
+-- first/last condition code is included)
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+
+
+procedure C940012 is
+
+ type Ramp_Index is range 1..4;
+
+ type Ramp;
+ type a_Ramp is access Ramp;
+
+ Ramp_Array : array (Ramp_Index) of a_Ramp;
+
+ -- Weighted load given to each potential problem area and accumulated
+ type Load_Factor is range 0..8;
+ Clear_Level : constant Load_Factor := 0;
+ Moderate_Level : constant Load_Factor := 3;
+
+ --================================================================
+ -- Only the Routines that are used in this test are shown
+ --
+ protected type Ramp (Ramp_In : Ramp_Index) is
+
+ function Ramp_Number return Ramp_Index;
+ function Local_Overload return Load_Factor;
+ function Next_Ramp_Overload return Load_Factor;
+ procedure Set_Local_Overload(Sensor_Level : Load_Factor);
+ procedure Notify;
+
+ private
+
+ Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble?
+
+ -- Current state of the various Sample Points
+ Local_State : Load_Factor := Clear_Level;
+
+ end Ramp;
+ --================================================================
+ protected body Ramp is
+
+ function Ramp_Number return Ramp_Index is
+ begin
+ return Ramp_In;
+ end Ramp_Number;
+
+ -- These Set/Clear routines are triggered by real-time sensors that
+ -- reflect traffic state
+ procedure Set_Local_Overload(Sensor_Level : Load_Factor) is
+ begin
+ if Local_State = Clear_Level then
+ -- Notify "previous" ramp to check this one for current state.
+ -- Subsequent changes in state will not send an alert
+ -- When the situation clears another routine performs the
+ -- all_clear notification. (not shown)
+ Ramp_Array(Ramp_In - 1).Notify; -- index to previous ramp
+ end if;
+ Local_State := Sensor_Level;
+ null; --::::: Start local meter if not already started
+ end;
+
+ function Local_Overload return Load_Factor is
+ begin
+ return Local_State;
+ end Local_Overload;
+
+ -- This is notification from the next ramp that it is in
+ -- overload. With this provision we only need to sample the next
+ -- ramp during adverse conditions.
+ procedure Notify is
+ begin
+ Next_Ramp_Alert := true;
+ end Notify;
+
+ function Next_Ramp_Overload return Load_Factor is
+ begin
+ if Next_Ramp_Alert then
+ -- Get next ramp's current state
+ return Ramp_Array(Ramp_In + 1).Local_Overload;
+ else
+ return Clear_Level;
+ end if;
+ end Next_Ramp_Overload;
+ end Ramp;
+ --================================================================
+
+begin
+
+
+ Report.Test ("C940012", "Check that a protected object " &
+ "can have discriminants");
+
+ -- Build the ramps and populate the ramp array
+ for i in Ramp_Index loop
+ Ramp_Array(i) := new Ramp (i);
+ end loop;
+
+ -- Test driver. This is ALL test control code
+
+ -- Check the assignment of the index
+ for i in Ramp_Index loop
+ if Ramp_Array(i).Ramp_Number /= i then
+ Report.Failed ("Ramp_Number assignment incorrect");
+ end if;
+ end loop;
+
+ -- Simulate calls to the protected functions and procedures
+ -- external calls. (do not call the "dummy" end ramps)
+
+ -- Simple Call
+ if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then
+ Report.Failed ("Primary call incorrect");
+ end if;
+
+ -- Call which results in an external procedure call via the array
+ -- index from within the protected object
+ Ramp_Array(3).Set_Local_Overload (Moderate_Level);
+
+ -- Call which results in an external function call via the array
+ -- index from within the protected object
+ if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then
+ Report.Failed ("Secondary call incorrect");
+ end if;
+
+
+ Report.Result;
+
+end C940012;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940013.a b/gcc/testsuite/ada/acats/tests/c9/c940013.a
new file mode 100644
index 000000000..58d34bc96
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940013.a
@@ -0,0 +1,379 @@
+-- C940013.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that items queued on a protected entry are handled FIFO and that
+-- the 'count attribute of that entry reflects the length of the queue.
+--
+-- TEST DESCRIPTION:
+-- Use a small subset of the freeway ramp simulation shown in other
+-- tests. With the timing pulse off (which prevents items from being
+-- removed from the queue) queue up a small number of calls. Start the
+-- timing pulse and, at the first execution of the entry code, check the
+-- 'count attribute. Empty the queue. Pass the items being removed from
+-- the queue to the Ramp_Sensor_01 task; there check that the items are
+-- arriving in FIFO order. Check the final 'count value
+--
+-- Send another batch of items at a rate which will, if the delay timing
+-- of the implementation is reasonable, cause the queue length to
+-- fluctuate in both directions. Again check that all items arrive
+-- FIFO. At the end check that the 'count returned to zero reflecting
+-- the empty queue.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+with ImpDef;
+with Ada.Calendar;
+
+procedure C940013 is
+
+ TC_Failed_1 : Boolean := false;
+
+begin
+
+ Report.Test ("C940013", "Check that queues on protected entries are " &
+ "handled FIFO and that 'count is correct");
+
+ declare -- encapsulate the test
+
+ function "+" (Left : Ada.Calendar.Time; Right: Duration)
+ return Ada.Calendar.Time renames Ada.Calendar."+";
+
+ -- Weighted load given to each potential problem area and accumulated
+ type Load_Factor is range 0..8;
+ Clear_Level : constant Load_Factor := 0;
+ Minimum_Level : constant Load_Factor := 1;
+ Moderate_Level : constant Load_Factor := 2;
+ Serious_Level : constant Load_Factor := 4;
+ Critical_Level : constant Load_Factor := 6;
+
+ TC_Expected_Passage_Total : constant integer := 624;
+
+ -- For this test give each vehicle an integer ID incremented
+ -- by one for each successive vehicle. In reality this would be
+ -- a more complex alpha-numeric ID assigned at pickup time.
+ type Vehicle_ID is range 1..5000;
+ Next_ID : Vehicle_ID := Vehicle_ID'first;
+
+ -- In reality this would be about 5 seconds. The default value of
+ -- this constant in the implementation defined package is similar
+ -- but could, of course be considerably different - it would not
+ -- affect the test
+ --
+ Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue;
+
+
+ task Pulse_Task; -- task to generate a pulse for each ramp
+
+ -- Carrier task. One is created for each vehicle arriving at the ramp
+ task type Vehicle is
+ entry Get_ID (Input_ID : in Vehicle_ID);
+ end Vehicle;
+ type acc_Vehicle is access Vehicle;
+
+ task Ramp_Sensor_01 is
+ entry Accept_Vehicle (Input_ID : in Vehicle_ID);
+ entry TC_First_Three_Handled;
+ entry TC_All_Done;
+ end Ramp_Sensor_01;
+
+ protected Pulse_State is
+ procedure Start_Pulse;
+ procedure Stop_Pulse;
+ function Pulsing return Boolean;
+ private
+ State : Boolean := false; -- start test will pulse off
+ end Pulse_State;
+
+ protected body Pulse_State is
+
+ procedure Start_Pulse is
+ begin
+ State := true;
+ end Start_Pulse;
+
+ procedure Stop_Pulse is
+ begin
+ State := false;
+ end Stop_Pulse;
+
+ function Pulsing return Boolean is
+ begin
+ return State;
+ end Pulsing;
+
+ end Pulse_State;
+
+ --================================================================
+ protected Test_Ramp is
+
+ function Meter_in_use_State return Boolean;
+ procedure Time_Pulse_Received;
+ entry Wait_at_Meter;
+ procedure TC_Passage (Pass_Point : Integer);
+ function TC_Get_Passage_Total return integer;
+ function TC_Get_Count return integer;
+
+ private
+
+ Release_One_Vehicle : Boolean := false;
+ -- For this test have Meter_in_Use already set
+ Meter_in_Use : Boolean := true;
+
+ TC_Wait_at_Meter_First : Boolean := true;
+ TC_Entry_Queue_Count : integer := 0; -- 'count of Wait_at_Meter
+ TC_Passage_Total : integer := 0;
+ TC_Pass_Point_WAM : integer := 23;
+
+ end Test_Ramp;
+ --================================================================
+ protected body Test_Ramp is
+
+ -- External call for Meter_in_Use
+ function Meter_in_Use_State return Boolean is
+ begin
+ return Meter_in_Use;
+ end Meter_in_Use_State;
+
+ -- Trace the paths through the various routines by totalling the
+ -- weighted call parameters
+ procedure TC_Passage (Pass_Point : Integer) is
+ begin
+ TC_Passage_Total := TC_Passage_Total + Pass_Point;
+ end TC_Passage;
+
+ -- For the final check of the whole test
+ function TC_Get_Passage_Total return integer is
+ begin
+ return TC_Passage_Total;
+ end TC_Get_Passage_Total;
+
+ function TC_Get_Count return integer is
+ begin
+ return TC_Entry_Queue_Count;
+ end TC_Get_Count;
+
+
+ -- Here each Vehicle task queues itself awaiting release
+ --
+ entry Wait_at_Meter when Release_One_Vehicle is
+ -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
+ begin
+ --
+ TC_Passage ( TC_Pass_Point_WAM ); -- note passage
+ -- For this test three vehicles are queued before the first
+ -- is released. If the queueing mechanism is working correctly
+ -- the first time we pass through here the entry'count should
+ -- reflect this
+ if TC_Wait_at_Meter_First then
+ if Wait_at_Meter'count /= 2 then
+ TC_Failed_1 := true;
+ end if;
+ TC_Wait_at_Meter_First := false;
+ end if;
+ TC_Entry_Queue_Count := Wait_at_Meter'count; -- note for later
+
+ Release_One_Vehicle := false; -- Consume the signal
+ null; -- stub ::: Decrement count of number of vehicles on ramp
+ end Wait_at_Meter;
+
+
+ procedure Time_Pulse_Received is
+ Load : Load_factor := Minimum_Level; -- for this version of the
+ Freeway_Breakdown : Boolean := false; -- test, freeway is Minimum
+ begin
+ -- if broken down, no vehicles are released
+ if not Freeway_Breakdown then
+ if Load < Moderate_Level then
+ Release_One_Vehicle := true;
+ end if;
+ null; -- stub ::: If other levels, release every other
+ -- pulse, every third pulse etc.
+ end if;
+ end Time_Pulse_Received;
+
+ end Test_Ramp;
+ --================================================================
+
+ -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
+ -- generation of an accompanying carrier task
+ procedure New_Arrival is
+ Next_Vehicle_Task: acc_Vehicle := new Vehicle;
+ TC_Pass_Point : constant integer := 3;
+ begin
+ Next_ID := Next_ID + 1;
+ Next_Vehicle_Task.Get_ID(Next_ID);
+ Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here
+ null;
+ end New_arrival;
+
+
+ -- Carrier task. One is created for each vehicle arriving at the ramp
+ task body Vehicle is
+ This_ID : Vehicle_ID;
+ TC_Pass_Point_2 : constant integer := 21;
+ begin
+ accept Get_ID (Input_ID : in Vehicle_ID) do
+ This_ID := Input_ID;
+ end Get_ID;
+
+ if Test_Ramp.Meter_in_Use_State then
+ Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage
+ null; -- stub::: Increment count of number of vehicles on ramp
+ Test_Ramp.Wait_at_Meter; -- Queue on the meter entry
+ end if;
+
+ -- Call to the first in the series of the Ramp_Sensors
+ -- this "passes" the vehicle from one sensor to the next
+ -- Each sensor will requeue the call to the next thus this
+ -- rendezvous will only be completed as the vehicle is released
+ -- by the last sensor on the ramp.
+ Ramp_Sensor_01.Accept_Vehicle (This_ID);
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Vehicle Task");
+ end Vehicle;
+
+ task body Ramp_Sensor_01 is
+ TC_Pass_Point : constant integer := 31;
+ This_ID : Vehicle_ID;
+ TC_Last_ID : Vehicle_ID := Vehicle_ID'first;
+ begin
+ loop
+ select
+ accept Accept_Vehicle (Input_ID : in Vehicle_ID) do
+ null; -- stub:::: match up with next Real-Time notification
+ -- from the sensor. Requeue to next ramp sensor
+ This_ID := Input_ID;
+
+ -- The following is all Test_Control code
+ Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage
+ -- The items arrive in the order they are taken from
+ -- the Wait_at_Meter entry queue
+ if ( This_ID - TC_Last_ID ) /= 1 then
+ -- The tasks are being queued (or unqueued) in the
+ -- wrong order
+ Report.Failed
+ ("Queueing on the Wait_at_Meter queue failed");
+ end if;
+ TC_Last_ID := This_ID; -- for the next check
+ if TC_Last_ID = 4 then
+ -- rendezvous with the test driver
+ accept TC_First_Three_Handled;
+ elsif TC_Last_ID = 9 then
+ -- rendezvous with the test driver
+ accept TC_All_Done;
+ end if;
+ end Accept_Vehicle;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Ramp_Sensor_01");
+ end Ramp_Sensor_01;
+
+
+ -- Task transmits a synchronizing "pulse" to all ramps
+ --
+ task body Pulse_Task is
+ Pulse_Time : Ada.Calendar.Time;
+ begin
+ While not Pulse_State.Pulsing loop
+ -- Starts up in the quiescent state
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ Pulse_Time := Ada.Calendar.Clock;
+ While Pulse_State.Pulsing loop
+ delay until Pulse_Time;
+ Test_Ramp. Time_Pulse_Received; -- Transmit pulse to test_ramp
+ -- :::::::::: and to all the other ramps
+ Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Pulse_Task");
+ end Pulse_Task;
+
+
+ begin -- declare
+
+ -- Test driver. This is ALL test control code
+
+ -- Arrange to queue three vehicles on the Wait_at_Meter queue. The
+ -- timing pulse is quiescent so the queue will build
+ for i in 1..3 loop
+ New_Arrival;
+ end loop;
+
+ delay Pulse_Time_Delta; -- ensure all is settled
+
+ Pulse_State.Start_Pulse; -- Start the timing pulse, the queue will
+ -- be serviced
+
+ -- wait here until the first three are complete
+ Ramp_Sensor_01.TC_First_Three_Handled;
+
+ if Test_Ramp.TC_Get_Count /= 0 then
+ Report.Failed ("Intermediate Wait_at_Entry'count is incorrect");
+ end if;
+
+ -- generate new arrivals at a rate that will make the queue increase
+ -- and decrease "randomly"
+ for i in 1..5 loop
+ New_Arrival;
+ delay Pulse_Time_Delta/2;
+ end loop;
+
+ -- wait here till all have been handled
+ Ramp_Sensor_01.TC_All_Done;
+
+ if Test_Ramp.TC_Get_Count /= 0 then
+ Report.Failed ("Final Wait_at_Entry'count is incorrect");
+ end if;
+
+ Pulse_State.Stop_Pulse; -- finish test
+
+
+ if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then
+ Report.Failed ("Unexpected paths taken");
+ end if;
+
+
+ end; -- declare
+
+ if TC_Failed_1 then
+ Report.Failed ("Wait_at_Meter'count incorrect");
+ end if;
+
+ Report.Result;
+
+end C940013;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940014.a b/gcc/testsuite/ada/acats/tests/c9/c940014.a
new file mode 100644
index 000000000..0eb53ea51
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940014.a
@@ -0,0 +1,177 @@
+-- C940014.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- TEST OBJECTIVE:
+-- Check that as part of the finalization of a protected object
+-- each call remaining on an entry queue of the objet is removed
+-- from its queue and Program_Error is raised at the place of
+-- the corresponding entry_call_statement.
+--
+-- TEST DESCRIPTION:
+-- The example in 9.4(20a-20f);6.0 demonstrates how to cause a
+-- protected object to finalize while tasks are still waiting
+-- on its entry queues. The first part of this test mirrors
+-- that example. The second part of the test expands upon
+-- the example code to add an object with finalization code
+-- to the protected object. The finalization code should be
+-- executed after Program_Error is raised in the callers left
+-- on the entry queues.
+--
+--
+-- CHANGE HISTORY:
+-- 08 Jan 96 SAIC Initial Release for 2.1
+-- 10 Jul 96 SAIC Incorporated Reviewer comments to fix race
+-- condition.
+--
+--!
+
+
+with Ada.Finalization;
+package C940014_0 is
+ Verbose : constant Boolean := False;
+ Finalization_Occurred : Boolean := False;
+
+ type Has_Finalization is new Ada.Finalization.Limited_Controlled with
+ record
+ Placeholder : Integer;
+ end record;
+ procedure Finalize (Object : in out Has_Finalization);
+end C940014_0;
+
+
+with Report;
+with ImpDef;
+package body C940014_0 is
+ procedure Finalize (Object : in out Has_Finalization) is
+ begin
+ delay ImpDef.Clear_Ready_Queue;
+ Finalization_Occurred := True;
+ if Verbose then
+ Report.Comment ("in Finalize");
+ end if;
+ end Finalize;
+end C940014_0;
+
+
+
+with Report;
+with ImpDef;
+with Ada.Finalization;
+with C940014_0;
+
+procedure C940014 is
+ Verbose : constant Boolean := C940014_0.Verbose;
+
+begin
+
+ Report.Test ("C940014", "Check that the finalization of a protected" &
+ " object results in program_error being raised" &
+ " at the point of the entry call statement for" &
+ " any tasks remaining on any entry queue");
+
+ First_Check: declare
+ -- example from ARM 9.4(20a-f);6.0 with minor mods
+ task T is
+ entry E;
+ end T;
+ task body T is
+ protected PO is
+ entry Ee;
+ end PO;
+ protected body PO is
+ entry Ee when Report.Ident_Bool (False) is
+ begin
+ null;
+ end Ee;
+ end PO;
+ begin
+ accept E do
+ requeue PO.Ee;
+ end E;
+ if Verbose then
+ Report.Comment ("task about to terminate");
+ end if;
+ end T;
+ begin -- First_Check
+ begin
+ T.E;
+ delay ImpDef.Clear_Ready_Queue;
+ Report.Failed ("exception not raised in First_Check");
+ exception
+ when Program_Error =>
+ if Verbose then
+ Report.Comment ("ARM Example passed");
+ end if;
+ when others =>
+ Report.Failed ("wrong exception in First_Check");
+ end;
+ end First_Check;
+
+
+ Second_Check : declare
+ -- here we want to check that the raising of Program_Error
+ -- occurs before the other finalization actions.
+ task T is
+ entry E;
+ end T;
+ task body T is
+ protected PO is
+ entry Ee;
+ private
+ Component : C940014_0.Has_Finalization;
+ end PO;
+ protected body PO is
+ entry Ee when Report.Ident_Bool (False) is
+ begin
+ null;
+ end Ee;
+ end PO;
+ begin
+ accept E do
+ requeue PO.Ee;
+ end E;
+ if Verbose then
+ Report.Comment ("task about to terminate");
+ end if;
+ end T;
+ begin -- Second_Check
+ T.E;
+ delay ImpDef.Clear_Ready_Queue;
+ Report.Failed ("exception not raised in Second_Check");
+ exception
+ when Program_Error =>
+ if C940014_0.Finalization_Occurred then
+ Report.Failed ("wrong order for finalization");
+ elsif Verbose then
+ Report.Comment ("Second_Check passed");
+ end if;
+ when others =>
+ Report.Failed ("Wrong exception in Second_Check");
+ end Second_Check;
+
+
+ Report.Result;
+
+end C940014;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940015.a b/gcc/testsuite/ada/acats/tests/c9/c940015.a
new file mode 100644
index 000000000..92a6699c3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940015.a
@@ -0,0 +1,149 @@
+-- C940015.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- TEST OBJECTIVE:
+-- Check that the component_declarations of a protected_operation
+-- are elaborated in the proper order.
+--
+-- TEST DESCRIPTION:
+-- A discriminated protected object is declared with some
+-- components that depend upon the discriminant and some that
+-- do not depend upon the discriminant. All the components
+-- are initialized with a function call. As a side-effect of
+-- the function call the parameter passed to the function is
+-- recorded in an elaboration order array.
+-- Two objects of the protected type are declared. The
+-- elaboration order is recorded and checked against the
+-- expected order.
+--
+--
+-- CHANGE HISTORY:
+-- 09 Jan 96 SAIC Initial Version for 2.1
+-- 09 Jul 96 SAIC Addressed reviewer comments.
+-- 13 Feb 97 PWB.CTA Removed doomed attempt to check per-object
+-- constraint elaborations.
+--!
+
+
+with Report;
+
+procedure C940015 is
+ Verbose : constant Boolean := False;
+ Do_Display : Boolean := Verbose;
+
+ type Index is range 0..10;
+
+ type List is array (1..10) of Integer;
+ Last : Natural range 0 .. List'Last := 0;
+ E_List : List := (others => 0);
+
+ function Elaborate (Id : Integer) return Index is
+ begin
+ Last := Last + 1;
+ E_List (Last) := Id;
+ if Verbose then
+ Report.Comment ("Elaborating" & Integer'Image (Id));
+ end if;
+ return Index(Id mod 10);
+ end Elaborate;
+
+ function Elaborate (Id, Per_Obj_Expr : Integer) return Index is
+ begin
+ return Elaborate (Id);
+ end Elaborate;
+
+begin
+
+ Report.Test ("C940015", "Check that the component_declarations of a" &
+ " protected object are elaborated in the" &
+ " proper order");
+ declare
+ -- an unprotected queue type
+ type Storage is array (Index range <>) of Integer;
+ type Queue (Size, Flag : Index := 1) is
+ record
+ Head : Index := 1;
+ Tail : Index := 1;
+ Count : Index := 0;
+ Buffer : Storage (1..Size);
+ end record;
+
+ -- protected group of queues type
+ protected type Prot_Queues (Size : Index := Elaborate (104)) is
+ procedure Clear;
+ -- other needed procedures not provided at this time
+ private
+ -- elaborate at type elaboration
+ Fixed_Queue_1 : Queue (3,
+ Elaborate (105));
+ -- elaborate at type elaboration
+ Fixed_Queue_2 : Queue (6,
+ Elaborate (107));
+ end Prot_Queues;
+ protected body Prot_Queues is
+ procedure Clear is
+ begin
+ Fixed_Queue_1.Count := 0;
+ Fixed_Queue_1.Head := 1;
+ Fixed_Queue_1.Tail := 1;
+ Fixed_Queue_2.Count := 0;
+ Fixed_Queue_2.Head := 1;
+ Fixed_Queue_2.Tail := 1;
+ end Clear;
+ end Prot_Queues;
+
+ PO1 : Prot_Queues(9);
+ PO2 : Prot_Queues;
+
+ Expected_Elab_Order : List := (
+ -- from the elaboration of the protected type Prot_Queues
+ 105, 107,
+ -- from the unconstrained object PO2
+ 104,
+ others => 0);
+ begin
+ for I in List'Range loop
+ if E_List (I) /= Expected_Elab_Order (I) then
+ Report.Failed ("wrong elaboration order");
+ Do_Display := True;
+ end if;
+ end loop;
+ if Do_Display then
+ Report.Comment ("Expected Actual");
+ for I in List'Range loop
+ Report.Comment (
+ Integer'Image (Expected_Elab_Order(I)) &
+ Integer'Image (E_List(I)));
+ end loop;
+ end if;
+
+ -- make use of the protected objects
+ PO1.Clear;
+ PO2.Clear;
+ end;
+
+ Report.Result;
+
+end C940015;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940016.a b/gcc/testsuite/ada/acats/tests/c9/c940016.a
new file mode 100644
index 000000000..2226eefb4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940016.a
@@ -0,0 +1,211 @@
+-- C940016.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- TEST OBJECTIVE:
+-- Check that an Unchecked_Deallocation of a protected object
+-- performs the required finalization on the protected object.
+--
+-- TEST DESCRIPTION:
+-- Test that finalization takes place when an Unchecked_Deallocation
+-- deallocates a protected object with queued callers.
+-- Try protected objects that have no other finalization code and
+-- protected objects with user defined finalization.
+--
+--
+-- CHANGE HISTORY:
+-- 16 Jan 96 SAIC ACVC 2.1
+-- 10 Jul 96 SAIC Fixed race condition noted by reviewers.
+--
+--!
+
+
+with Ada.Finalization;
+package C940016_0 is
+ Verbose : constant Boolean := False;
+ Finalization_Occurred : Boolean := False;
+
+ type Has_Finalization is new Ada.Finalization.Limited_Controlled with
+ record
+ Placeholder : Integer;
+ end record;
+ procedure Finalize (Object : in out Has_Finalization);
+end C940016_0;
+
+
+with Report;
+with ImpDef;
+package body C940016_0 is
+ procedure Finalize (Object : in out Has_Finalization) is
+ begin
+ delay ImpDef.Clear_Ready_Queue;
+ Finalization_Occurred := True;
+ if Verbose then
+ Report.Comment ("in Finalize");
+ end if;
+ end Finalize;
+end C940016_0;
+
+
+
+with Report;
+with Ada.Finalization;
+with C940016_0;
+with Ada.Unchecked_Deallocation;
+with ImpDef;
+
+procedure C940016 is
+ Verbose : constant Boolean := C940016_0.Verbose;
+
+begin
+
+ Report.Test ("C940016", "Check that Unchecked_Deallocation of a" &
+ " protected object finalizes the" &
+ " protected object");
+
+ First_Check: declare
+ protected type Semaphore is
+ entry Wait;
+ procedure Signal;
+ private
+ Count : Integer := 0;
+ end Semaphore;
+ protected body Semaphore is
+ entry Wait when Count > 0 is
+ begin
+ Count := Count - 1;
+ end Wait;
+
+ procedure Signal is
+ begin
+ Count := Count + 1;
+ end Signal;
+ end Semaphore;
+
+ type pSem is access Semaphore;
+ procedure Zap_Semaphore is new
+ Ada.Unchecked_Deallocation (Semaphore, pSem);
+ Sem_Ptr : pSem := new Semaphore;
+
+ -- positive confirmation that Blocker got the exception
+ Ok : Boolean := False;
+
+ task Blocker;
+
+ task body Blocker is
+ begin
+ Sem_Ptr.Wait;
+ Report.Failed ("Program_Error not raised in waiting task");
+ exception
+ when Program_Error =>
+ Ok := True;
+ if Verbose then
+ Report.Comment ("Blocker received Program_Error");
+ end if;
+ when others =>
+ Report.Failed ("Wrong exception in Blocker");
+ end Blocker;
+
+ begin -- First_Check
+ -- wait for Blocker to get blocked on the semaphore
+ delay ImpDef.Clear_Ready_Queue;
+ Zap_Semaphore (Sem_Ptr);
+ -- make sure Blocker has time to complete
+ delay ImpDef.Clear_Ready_Queue * 2;
+ if not Ok then
+ Report.Failed ("finalization not properly performed");
+ -- Blocker is probably hung so kill it
+ abort Blocker;
+ end if;
+ end First_Check;
+
+
+ Second_Check : declare
+ -- here we want to check that the raising of Program_Error
+ -- occurs before the other finalization actions.
+ protected type Semaphore is
+ entry Wait;
+ procedure Signal;
+ private
+ Count : Integer := 0;
+ Component : C940016_0.Has_Finalization;
+ end Semaphore;
+ protected body Semaphore is
+ entry Wait when Count > 0 is
+ begin
+ Count := Count - 1;
+ end Wait;
+
+ procedure Signal is
+ begin
+ Count := Count + 1;
+ end Signal;
+ end Semaphore;
+
+ type pSem is access Semaphore;
+ procedure Zap_Semaphore is new
+ Ada.Unchecked_Deallocation (Semaphore, pSem);
+ Sem_Ptr : pSem := new Semaphore;
+
+ -- positive confirmation that Blocker got the exception
+ Ok : Boolean := False;
+
+ task Blocker;
+
+ task body Blocker is
+ begin
+ Sem_Ptr.Wait;
+ Report.Failed ("Program_Error not raised in waiting task 2");
+ exception
+ when Program_Error =>
+ Ok := True;
+ if C940016_0.Finalization_Occurred then
+ Report.Failed ("wrong order for finalization 2");
+ elsif Verbose then
+ Report.Comment ("Blocker received Program_Error 2");
+ end if;
+ when others =>
+ Report.Failed ("Wrong exception in Blocker 2");
+ end Blocker;
+
+ begin -- Second_Check
+ -- wait for Blocker to get blocked on the semaphore
+ delay ImpDef.Clear_Ready_Queue;
+ Zap_Semaphore (Sem_Ptr);
+ -- make sure Blocker has time to complete
+ delay ImpDef.Clear_Ready_Queue * 2;
+ if not Ok then
+ Report.Failed ("finalization not properly performed 2");
+ -- Blocker is probably hung so kill it
+ abort Blocker;
+ end if;
+ if not C940016_0.Finalization_Occurred then
+ Report.Failed ("user defined finalization didn't happen");
+ end if;
+ end Second_Check;
+
+
+ Report.Result;
+
+end C940016;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001a.ada b/gcc/testsuite/ada/acats/tests/c9/c94001a.ada
new file mode 100644
index 000000000..e23a3b86d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94001a.ada
@@ -0,0 +1,259 @@
+-- C94001A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY OBJECT
+-- DECLARATIONS IS NOT TERMINATED UNTIL ALL DEPENDENT TASKS BECOME
+-- TERMINATED.
+-- SUBTESTS ARE:
+-- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK.
+-- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION.
+-- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY.
+
+-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS.
+
+-- JRK 10/2/81
+-- SPS 11/21/82
+-- JRK 11/29/82
+-- TBN 8/22/86 REVISED; ADDED CASES THAT EXIT BY RAISING AN
+-- EXCEPTION.
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94001A IS
+
+ MY_EXCEPTION : EXCEPTION;
+ GLOBAL : INTEGER;
+
+ TASK TYPE TT IS
+ ENTRY E (I : INTEGER);
+ END TT;
+
+ TASK BODY TT IS
+ LOCAL : INTEGER;
+ BEGIN
+ ACCEPT E (I : INTEGER) DO
+ LOCAL := I;
+ END E;
+ DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY
+ -- AT THIS POINT, IT WILL RECEIVE CONTROL AND
+ -- TERMINATE IF THE ERROR IS PRESENT.
+ GLOBAL := LOCAL;
+ END TT;
+
+
+BEGIN
+ TEST ("C94001A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " &
+ "CREATED BY OBJECT DECLARATIONS IS NOT " &
+ "TERMINATED UNTIL ALL DEPENDENT TASKS " &
+ "BECOME TERMINATED");
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (A)
+
+ T : TT;
+
+ BEGIN -- (A)
+
+ T.E (IDENT_INT(1));
+
+ END; -- (A)
+
+ IF GLOBAL /= 1 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 1");
+ END IF;
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ BEGIN -- (B)
+ DECLARE
+ T : TT;
+ BEGIN
+ T.E (IDENT_INT(1));
+ RAISE MY_EXCEPTION;
+ END;
+
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 2");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 1 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 2");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION - 2");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ BEGIN
+ A(1).E (IDENT_INT(2));
+ RETURN 0;
+ END F;
+
+ BEGIN -- (C)
+
+ I := F;
+
+ IF GLOBAL /= 2 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 3");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (D)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ BEGIN
+ A(1).E (IDENT_INT(2));
+ IF EQUAL (3, 3) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ RETURN 0;
+ END F;
+
+ BEGIN -- (D)
+ I := F;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 4");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 2 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 4");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION - 4");
+ END; -- (D)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (E)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ BEGIN
+ AR(1).T.E (IDENT_INT(3));
+ END TSK;
+
+ BEGIN -- (E)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " &
+ "HOUR - 5");
+ ELSIF GLOBAL /= 3 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "TASK EXIT - 5");
+ END IF;
+
+ END; -- (E)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (F)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ BEGIN
+ AR(1).T.E (IDENT_INT(3));
+ IF EQUAL (3, 3) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ FAILED ("EXCEPTION WAS NOT RAISED - 6");
+ END TSK;
+
+ BEGIN -- (F)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " &
+ "HOUR - 6");
+ ELSIF GLOBAL /= 3 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "TASK EXIT - 6");
+ END IF;
+
+ END; -- (F)
+
+ --------------------------------------------------
+
+ RESULT;
+END C94001A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001b.ada b/gcc/testsuite/ada/acats/tests/c9/c94001b.ada
new file mode 100644
index 000000000..e3e2edaa3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94001b.ada
@@ -0,0 +1,268 @@
+-- C94001B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY AN OBJECT
+-- DECLARATION OF LIMITED PRIVATE TYPE IS NOT TERMINATED UNTIL ALL
+-- DEPENDENT TASKS BECOME TERMINATED.
+-- SUBTESTS ARE:
+-- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK.
+-- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION.
+-- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY.
+
+-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS.
+
+-- TBN 8/22/86
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94001B IS
+
+ PACKAGE P IS
+ MY_EXCEPTION : EXCEPTION;
+ GLOBAL : INTEGER;
+ TYPE TT IS LIMITED PRIVATE;
+ PROCEDURE CALL_ENTRY (A : TT; B : INTEGER);
+ PRIVATE
+ TASK TYPE TT IS
+ ENTRY E (I : INTEGER);
+ END TT;
+ END P;
+
+ PACKAGE BODY P IS
+
+ PROCEDURE CALL_ENTRY (A : TT; B : INTEGER) IS
+ BEGIN
+ A.E (B);
+ END CALL_ENTRY;
+
+ TASK BODY TT IS
+ LOCAL : INTEGER;
+ BEGIN
+ ACCEPT E (I : INTEGER) DO
+ LOCAL := I;
+ END E;
+ DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER
+ -- PRIORITY AT THIS POINT, IT WILL
+ -- RECEIVE CONTROL AND TERMINATE IF
+ -- THE ERROR IS PRESENT.
+ GLOBAL := LOCAL;
+ END TT;
+ END P;
+
+ USE P;
+
+
+BEGIN
+ TEST ("C94001B", "CHECK THAT A UNIT WITH DEPENDENT TASKS " &
+ "CREATED BY AN OBJECT DECLARATION OF LIMITED " &
+ "PRIVATE TYPE IS NOT TERMINATED UNTIL ALL " &
+ "DEPENDENT TASKS BECOME TERMINATED");
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (A)
+
+ T : TT;
+
+ BEGIN -- (A)
+
+ CALL_ENTRY (T, IDENT_INT(1));
+
+ END; -- (A)
+
+ IF GLOBAL /= 1 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 1");
+ END IF;
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ BEGIN -- (B)
+ DECLARE
+ T : TT;
+ BEGIN
+ CALL_ENTRY (T, IDENT_INT(2));
+ RAISE MY_EXCEPTION;
+ END;
+
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 2");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 2 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 2");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION - 2");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ BEGIN
+ CALL_ENTRY (A(1), IDENT_INT(3));
+ RETURN 0;
+ END F;
+
+ BEGIN -- (C)
+
+ I := F;
+
+ IF GLOBAL /= 3 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 3");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (D)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ BEGIN
+ CALL_ENTRY (A(1), IDENT_INT(4));
+ IF EQUAL (3, 3) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ RETURN 0;
+ END F;
+
+ BEGIN -- (D)
+ I := F;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 4");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 4 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 4");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION - 4");
+ END; -- (D)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (E)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ BEGIN
+ CALL_ENTRY (AR(1).T, IDENT_INT(5));
+ END TSK;
+
+ BEGIN -- (E)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " &
+ "HOUR - 5");
+ ELSIF GLOBAL /= 5 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "TASK EXIT - 5");
+ END IF;
+
+ END; -- (E)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (F)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ BEGIN
+ CALL_ENTRY (AR(1).T, IDENT_INT(6));
+ IF EQUAL (3, 3) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ FAILED ("EXCEPTION WAS NOT RAISED - 6");
+ END TSK;
+
+ BEGIN -- (F)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " &
+ "HOUR - 6");
+ ELSIF GLOBAL /= 6 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "TASK EXIT - 6");
+ END IF;
+
+ END; -- (F)
+
+ RESULT;
+END C94001B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001c.ada b/gcc/testsuite/ada/acats/tests/c9/c94001c.ada
new file mode 100644
index 000000000..1d0625559
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94001c.ada
@@ -0,0 +1,267 @@
+-- C94001C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A UNIT WITH INDIRECT DEPENDENT TASKS CREATED BY OBJECT
+-- DECLARATIONS IS NOT TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS
+-- BECOME TERMINATED.
+-- SUBTESTS ARE:
+-- (A, B) A BLOCK CONTAINING A SIMPLE TASK OBJECT, IN A BLOCK.
+-- (C, D) A FUNCTION CONTAINING AN ARRAY OF TASK OBJECT, IN A
+-- FUNCTION.
+-- (E, F) A TASK CONTAINING AN ARRAY OF RECORD OF TASK OBJECT,
+-- IN A TASK BODY.
+-- CASES (B, D, F) EXIT BY RAISING AN EXCEPTION.
+
+-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS.
+
+-- TBN 8/25/86
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94001C IS
+
+ MY_EXCEPTION : EXCEPTION;
+ GLOBAL : INTEGER;
+
+ TASK TYPE TT IS
+ ENTRY E (I : INTEGER);
+ END TT;
+
+ TASK BODY TT IS
+ LOCAL : INTEGER;
+ BEGIN
+ ACCEPT E (I : INTEGER) DO
+ LOCAL := I;
+ END E;
+ DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY
+ -- AT THIS POINT, IT WILL RECEIVE CONTROL AND
+ -- TERMINATE IF THE ERROR IS PRESENT.
+ GLOBAL := LOCAL;
+ END TT;
+
+
+BEGIN
+ TEST ("C94001C", "CHECK THAT A UNIT WITH INDIRECT DEPENDENT " &
+ "TASKS CREATED BY OBJECT DECLARATIONS IS NOT " &
+ "TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS " &
+ "BECOME TERMINATED");
+
+ --------------------------------------------------
+ GLOBAL := IDENT_INT (0);
+
+ BEGIN -- (A)
+
+ DECLARE
+ T : TT;
+ BEGIN
+ T.E (IDENT_INT(1));
+ END;
+
+ END; -- (A)
+
+ IF GLOBAL /= 1 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 1");
+ END IF;
+
+ --------------------------------------------------
+
+ BEGIN -- (B)
+ GLOBAL := IDENT_INT (0);
+
+ BEGIN
+ DECLARE
+ T : TT;
+ BEGIN
+ T.E (IDENT_INT(2));
+ RAISE MY_EXCEPTION;
+ END;
+ END;
+
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 2");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 2 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 2");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION - 2");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C)
+
+ OBJ_INT : INTEGER;
+
+ FUNCTION F1 RETURN INTEGER IS
+ I : INTEGER;
+
+ FUNCTION F2 RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ BEGIN
+ A(1).E (IDENT_INT(3));
+ RETURN 0;
+ END F2;
+ BEGIN
+ I := F2;
+ RETURN (0);
+ END F1;
+
+ BEGIN -- (C)
+ OBJ_INT := F1;
+ IF GLOBAL /= 3 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 3");
+ END IF;
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ OBJ_INT : INTEGER;
+
+ FUNCTION F1 RETURN INTEGER IS
+ I : INTEGER;
+
+ FUNCTION F2 RETURN INTEGER IS
+ A : ARRAY (1..1) OF TT;
+ BEGIN
+ A(1).E (IDENT_INT(4));
+ IF EQUAL (3, 3) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ RETURN 0;
+ END F2;
+ BEGIN
+ I := F2;
+ RETURN (0);
+ END F1;
+
+ BEGIN -- (D)
+ GLOBAL := IDENT_INT (0);
+ OBJ_INT := F1;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 4");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 4 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 4");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION - 4");
+ END; -- (D)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (E)
+ DELAY_COUNT : INTEGER := 0;
+ TASK OUT_TSK;
+
+ TASK BODY OUT_TSK IS
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ BEGIN
+ AR(1).T.E (IDENT_INT(5));
+ END TSK;
+
+ BEGIN
+ NULL;
+ END OUT_TSK;
+
+ BEGIN -- (E)
+ WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP
+ DELAY 1.0 * Impdef.One_Long_Second;
+ DELAY_COUNT := DELAY_COUNT + 1;
+ END LOOP;
+ IF DELAY_COUNT = 60 THEN
+ FAILED ("OUT_TSK HAS NOT TERMINATED - 5");
+ ELSIF GLOBAL /= 5 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 5");
+ END IF;
+ END; -- (E)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE
+ DELAY_COUNT : INTEGER := 0;
+
+ TASK OUT_TSK;
+
+ TASK BODY OUT_TSK IS
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ AR : ARRAY (1..1) OF RT;
+ BEGIN
+ AR(1).T.E (IDENT_INT(6));
+ RAISE MY_EXCEPTION;
+ END TSK;
+
+ BEGIN
+ RAISE MY_EXCEPTION;
+ END OUT_TSK;
+
+ BEGIN
+ WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP
+ DELAY 1.0 * Impdef.One_Long_Second;
+ DELAY_COUNT := DELAY_COUNT + 1;
+ END LOOP;
+ IF DELAY_COUNT = 60 THEN
+ FAILED ("OUT_TSK HAS NOT TERMINATED - 6");
+ ELSIF GLOBAL /= 6 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 6");
+ END IF;
+ END;
+
+ RESULT;
+END C94001C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001e.ada b/gcc/testsuite/ada/acats/tests/c9/c94001e.ada
new file mode 100644
index 000000000..4ab502cd5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94001e.ada
@@ -0,0 +1,81 @@
+-- C94001E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY
+-- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS.
+-- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT.
+-- VERSION WITH EXCEPTION HANDLER.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C940AGA-B.ADA
+-- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION.
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C94001E IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+BEGIN
+
+ TEST ("C94001E", "TASK COMPLETION BY EXCEPTION");
+
+BLOCK:
+ DECLARE
+
+ TASK T1;
+
+ TASK BODY T1 IS
+ TYPE I1 IS RANGE 0 .. 1;
+ OBJ_I1 : I1;
+ BEGIN
+ OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR.
+ IF OBJ_I1 /= I1(IDENT_INT(0)) THEN
+ PSPY_NUMB (1);
+ ELSE
+ PSPY_NUMB (2);
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR => NULL;
+ WHEN OTHERS => FAILED ("OTHER EXCEPTION RAISED");
+ END T1;
+
+ BEGIN
+ NULL;
+ END BLOCK;
+
+ IF SPYNUMB /= 0 THEN
+ FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C94001E;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001f.ada b/gcc/testsuite/ada/acats/tests/c9/c94001f.ada
new file mode 100644
index 000000000..82adc32f6
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94001f.ada
@@ -0,0 +1,80 @@
+-- C94001F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY
+-- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS.
+-- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT.
+-- VERSION WITHOUT EXCEPTION HANDLER.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C940AGB-B.ADA
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C94001F IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+BEGIN
+
+ TEST ("C94001F", "TASK COMPLETION BY EXCEPTION -- NO HANDLER");
+
+BLOCK:
+ DECLARE
+
+ TASK T1;
+
+ TASK BODY T1 IS
+ TYPE I1 IS RANGE 0 .. 1;
+ OBJ_I1 : I1;
+ BEGIN
+ OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR.
+ PSPY_NUMB (1);
+ END T1;
+
+ BEGIN
+ NULL; -- WAIT FOR TERMINATION.
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("PROPAGATED CONSTRAINT_ERROR OUT OF TASK");
+ WHEN TASKING_ERROR =>
+ FAILED ("RAISED TASKING_ERROR");
+ WHEN OTHERS =>
+ FAILED ("RAISED OTHER EXCEPTION");
+ END BLOCK;
+
+ IF SPYNUMB /= 0 THEN
+ FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION IN SEQUENCE " &
+ "OF STATEMENTS");
+ END IF;
+
+ RESULT;
+
+END C94001F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001g.ada b/gcc/testsuite/ada/acats/tests/c9/c94001g.ada
new file mode 100644
index 000000000..294bb53a5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94001g.ada
@@ -0,0 +1,124 @@
+-- C94001G.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A COMPLETED TASK WITH DEPENDENT TASKS TERMINATES WHEN
+-- A L L DEPENDENT TASKS HAVE TERMINATED.
+
+-- WEI 3/ 4/82
+-- JBG 4/2/84
+-- JWC 6/28/85 RENAMED FROM C940AIA-B.ADA
+
+with Impdef;
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C94001G IS
+
+ PACKAGE SPY IS -- PROVIDE PROTECTED ACCESS TO SPYNUMB
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ FUNCTION SPYNUMB RETURN NATURAL; -- READ
+ FUNCTION FINIT_POS (DIGT : IN ARG) RETURN NATURAL; -- WRITE
+ PROCEDURE PSPY_NUMB (DIGT : IN ARG); -- WRITE
+ END SPY;
+
+ USE SPY;
+
+ PACKAGE BODY SPY IS
+
+ TASK GUARD IS
+ ENTRY READ (NUMB : OUT NATURAL);
+ ENTRY WRITE (NUMB : IN NATURAL);
+ END GUARD;
+
+ TASK BODY GUARD IS
+ SPYNUMB : NATURAL := 0;
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT READ (NUMB : OUT NATURAL) DO
+ NUMB := SPYNUMB;
+ END READ;
+ OR ACCEPT WRITE (NUMB : IN NATURAL) DO
+ SPYNUMB := 10*SPYNUMB+NUMB;
+ END WRITE;
+ OR TERMINATE;
+ END SELECT;
+ END LOOP;
+ END GUARD;
+
+ FUNCTION SPYNUMB RETURN NATURAL IS
+ TEMP : NATURAL;
+ BEGIN
+ GUARD.READ (TEMP);
+ RETURN TEMP;
+ END SPYNUMB;
+
+ FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS
+ BEGIN
+ GUARD.WRITE (DIGT);
+ RETURN DIGT;
+ END FINIT_POS;
+
+ PROCEDURE PSPY_NUMB (DIGT : IN ARG) IS
+ BEGIN
+ GUARD.WRITE (DIGT);
+ END PSPY_NUMB;
+ END SPY;
+
+BEGIN
+ TEST ("C94001G", "TERMINATION WHEN ALL DEPENDENT TASKS " &
+ "HAVE TERMINATED");
+
+BLOCK:
+ DECLARE
+
+ TASK TYPE TT1;
+
+ TASK BODY TT1 IS
+ BEGIN
+ DELAY 1.0 * Impdef.One_Second;
+ PSPY_NUMB (1);
+ END TT1;
+
+ TASK T1 IS
+ END T1;
+
+ TASK BODY T1 IS
+ OBJ_TT1_1, OBJ_TT1_2, OBJ_TT1_3 : TT1;
+ BEGIN
+ NULL;
+ END T1;
+
+ BEGIN
+ NULL;
+ END BLOCK; -- WAIT HERE FOR TERMINATION.
+
+ IF SPYNUMB /= 111 THEN
+ FAILED ("TASK T1 TERMINATED BEFORE " &
+ "ALL DEPENDENT TASKS HAVE TERMINATED");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C94001G;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002a.ada b/gcc/testsuite/ada/acats/tests/c9/c94002a.ada
new file mode 100644
index 000000000..6db8f962b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94002a.ada
@@ -0,0 +1,331 @@
+-- C94002A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY (LOCAL)
+-- ALLOCATORS DOES NOT TERMINATE UNTIL ALL DEPENDENT TASKS ARE
+-- TERMINATED.
+-- SUBTESTS ARE:
+-- (A, B) A SIMPLE TASK ALLOCATOR, IN A BLOCK.
+-- (C, D) A RECORD OF TASK ALLOCATOR, IN A FUNCTION.
+-- (E, F) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY.
+
+-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS.
+
+-- JRK 10/2/81
+-- SPS 11/2/82
+-- SPS 11/21/82
+-- JRK 11/29/82
+-- TBN 8/25/86 REDUCED DELAYS; ADDED LIMITED PRIVATE TYPES;
+-- INCLUDED EXITS BY RAISING AN EXCEPTION.
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94002A IS
+
+ PACKAGE P IS
+ MY_EXCEPTION : EXCEPTION;
+ GLOBAL : INTEGER;
+ TASK TYPE T1 IS
+ ENTRY E (I : INTEGER);
+ END T1;
+ TYPE T2 IS LIMITED PRIVATE;
+ PROCEDURE CALL_ENTRY (A : T2; B : INTEGER);
+ PRIVATE
+ TASK TYPE T2 IS
+ ENTRY E (I : INTEGER);
+ END T2;
+ END P;
+
+ PACKAGE BODY P IS
+ TASK BODY T1 IS
+ LOCAL : INTEGER;
+ BEGIN
+ ACCEPT E (I : INTEGER) DO
+ LOCAL := I;
+ END E;
+ DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER
+ -- PRIORITY AT THIS POINT, IT WILL
+ -- RECEIVE CONTROL AND TERMINATE IF
+ -- THE ERROR IS PRESENT.
+ GLOBAL := LOCAL;
+ END T1;
+
+ TASK BODY T2 IS
+ LOCAL : INTEGER;
+ BEGIN
+ ACCEPT E (I : INTEGER) DO
+ LOCAL := I;
+ END E;
+ DELAY 30.0 * Impdef.One_Second;
+ GLOBAL := LOCAL;
+ END T2;
+
+ PROCEDURE CALL_ENTRY (A : T2; B : INTEGER) IS
+ BEGIN
+ A.E (B);
+ END CALL_ENTRY;
+ END P;
+
+ USE P;
+
+
+BEGIN
+ TEST ("C94002A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " &
+ "CREATED BY (LOCAL) ALLOCATORS DOES NOT " &
+ "TERMINATE UNTIL ALL DEPENDENT TASKS " &
+ "ARE TERMINATED");
+
+ --------------------------------------------------
+ GLOBAL := IDENT_INT (0);
+ BEGIN -- (A)
+ DECLARE
+ TYPE A_T IS ACCESS T1;
+ A : A_T;
+ BEGIN
+ IF EQUAL (3, 3) THEN
+ A := NEW T1;
+ A.ALL.E (IDENT_INT(1));
+ RAISE MY_EXCEPTION;
+ END IF;
+ END;
+
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 1");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 1 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 1");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (B)
+ TYPE A_T IS ACCESS T2;
+ A : A_T;
+ BEGIN -- (B)
+ IF EQUAL (3, 3) THEN
+ A := NEW T2;
+ CALL_ENTRY (A.ALL, IDENT_INT(2));
+ END IF;
+ END; -- (B)
+
+ IF GLOBAL /= 2 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - 2");
+ END IF;
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C)
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ TYPE RT;
+ TYPE ART IS ACCESS RT;
+ TYPE RT IS
+ RECORD
+ A : ART;
+ T : T1;
+ END RECORD;
+ LIST : ART;
+ TEMP : ART;
+ BEGIN
+ FOR I IN 1 .. IDENT_INT (1) LOOP
+ TEMP := NEW RT;
+ TEMP.A := LIST;
+ LIST := TEMP;
+ LIST.T.E (IDENT_INT(3));
+ END LOOP;
+ RETURN 0;
+ END F;
+ BEGIN -- (C)
+ I := F;
+
+ IF GLOBAL /= 3 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 3");
+ END IF;
+ END; -- (C)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (D)
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+ TYPE RT;
+ TYPE ART IS ACCESS RT;
+ TYPE RT IS
+ RECORD
+ A : ART;
+ T : T2;
+ END RECORD;
+ LIST : ART;
+ TEMP : ART;
+ BEGIN
+ FOR I IN 1 .. IDENT_INT (1) LOOP
+ TEMP := NEW RT;
+ TEMP.A := LIST;
+ LIST := TEMP;
+ CALL_ENTRY (LIST.T, IDENT_INT(4));
+ IF EQUAL (3, 3) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ END LOOP;
+ RETURN 0;
+ END F;
+ BEGIN -- (D)
+ I := F;
+
+ FAILED ("MY_EXCEPTION WAS NOT RAISED - 4");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL /= 4 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - 4");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
+ END; -- (D)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (E)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE ARR IS ARRAY (1..1) OF T1;
+ TYPE RAT;
+ TYPE ARAT IS ACCESS RAT;
+ TYPE RAT IS
+ RECORD
+ A : ARAT;
+ T : ARR;
+ END RECORD;
+ LIST : ARAT;
+ TEMP : ARAT;
+ BEGIN
+ FOR I IN 1 .. IDENT_INT (1) LOOP
+ TEMP := NEW RAT;
+ TEMP.A := LIST;
+ LIST := TEMP;
+ LIST.T(1).E (IDENT_INT(5));
+ IF EQUAL (3, 3) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ END LOOP;
+ END TSK;
+
+ BEGIN -- (E)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " &
+ "MINUTES - 5");
+ END IF;
+
+ IF GLOBAL /= 5 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "TASK EXIT - 5");
+ END IF;
+
+ END; -- (E)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (F)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ TYPE ARR IS ARRAY (1..1) OF T2;
+ TYPE RAT;
+ TYPE ARAT IS ACCESS RAT;
+ TYPE RAT IS
+ RECORD
+ A : ARAT;
+ T : ARR;
+ END RECORD;
+ LIST : ARAT;
+ TEMP : ARAT;
+ BEGIN
+ FOR I IN 1 .. IDENT_INT (1) LOOP
+ TEMP := NEW RAT;
+ TEMP.A := LIST;
+ LIST := TEMP;
+ CALL_ENTRY (LIST.T(1), IDENT_INT(6));
+ END LOOP;
+ END TSK;
+
+ BEGIN -- (F)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " &
+ "MINUTES - 6");
+ END IF;
+
+ IF GLOBAL /= 6 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "TASK EXIT - 6");
+ END IF;
+
+ END; -- (F)
+
+ RESULT;
+END C94002A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002b.ada b/gcc/testsuite/ada/acats/tests/c9/c94002b.ada
new file mode 100644
index 000000000..1f226f7c5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94002b.ada
@@ -0,0 +1,208 @@
+-- C94002B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL ACCESS
+-- TYPE MAY TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS TO
+-- TERMINATE.
+
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK.
+-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM.
+-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY.
+
+-- JRK 10/8/81
+-- SPS 11/2/82
+-- SPS 11/21/82
+-- JRK 11/29/82
+-- TBN 1/20/86 REPLACED WITH C94006A-B.ADA AFTER LOWERING THE DELAY
+-- VALUES, AND MODIFYING THE COMMENTS.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94002B IS
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ BEGIN
+ ACCEPT E;
+ ACCEPT E;
+ END TT;
+
+
+BEGIN
+ TEST ("C94002B", "CHECK THAT A MASTER UNIT, WHICH ALLOCATES " &
+ "TASKS OF A GLOBAL ACCESS TYPE MAY TERMINATE " &
+ "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " &
+ "TERMINATE");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE A_T IS ACCESS TT;
+ A1 : A_T;
+
+ BEGIN -- (A)
+
+ DECLARE
+ A2 : A_T;
+ BEGIN
+ A2 := NEW TT;
+ A2.ALL.E;
+ A1 := A2;
+ END;
+
+ IF A1.ALL'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)");
+ END IF;
+
+ A1.ALL.E;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ TYPE ART IS ACCESS RT;
+ AR1 : ART;
+
+ PROCEDURE P (AR : OUT ART) IS
+ AR2 : ART;
+ BEGIN
+ AR2 := NEW RT;
+ AR2.T.E;
+ AR := AR2;
+ END P;
+
+ BEGIN
+ P (AR1);
+
+ IF AR1.T'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " &
+ "- (B)");
+ END IF;
+
+ AR1.T.E;
+ RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ I := F;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60; -- DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+
+ LOOP_COUNT1 : INTEGER := 0;
+ CUT_OFF1 : CONSTANT := 60; -- DELAY.
+
+ TYPE RAT;
+ TYPE ARAT IS ACCESS RAT;
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RAT IS
+ RECORD
+ A : ARAT;
+ T : ARR;
+ END RECORD;
+ ARA1 : ARAT;
+
+ TASK TSK1 IS
+ ENTRY ENT1 (ARA : OUT ARAT);
+ END TSK1;
+
+ TASK BODY TSK1 IS
+ ARA2 : ARAT;
+ BEGIN
+ ARA2 := NEW RAT;
+ ARA2.T(1).E;
+ ACCEPT ENT1 (ARA : OUT ARAT) DO
+ ARA := ARA2;
+ END ENT1;
+ END TSK1;
+
+ BEGIN
+ TSK1.ENT1 (ARA1);
+
+ WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT1 := LOOP_COUNT1 + 1;
+ END LOOP;
+
+ IF LOOP_COUNT1 >= CUT_OFF1 THEN
+ FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " &
+ "WITHIN ONE MINUTE - (C)");
+ END IF;
+
+ IF ARA1.T(1)'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " &
+ "- (C)");
+ END IF;
+
+ ARA1.T(1).E;
+ END TSK;
+
+ BEGIN -- (C)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 2.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " &
+ "TWO MINUTES - (C)");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+END C94002B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002d.ada b/gcc/testsuite/ada/acats/tests/c9/c94002d.ada
new file mode 100644
index 000000000..372fac0bf
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94002d.ada
@@ -0,0 +1,74 @@
+-- C94002D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK DOES N O T DEPEND ON A UNIT IF IT IS DESIGNATED
+-- BY A LOCAL ACCESS VARIABLE (OF THIS UNIT) WHOSE TYPE IS DECLARED
+-- OUTSIDE THIS UNIT.
+
+-- WEI 3/ 4/82
+-- JBG 2/20/84
+-- TBN 11/25/85 RENAMED FROM C940ACB-B.ADA.
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C94002D IS
+
+ TASK TYPE TT1 IS
+ ENTRY E1;
+ ENTRY E2;
+ END TT1;
+
+ TYPE ATT1 IS ACCESS TT1;
+ OUTER_TT1 : ATT1;
+
+ TASK BODY TT1 IS
+ BEGIN
+ ACCEPT E1;
+ ACCEPT E2;
+ END TT1;
+
+BEGIN
+ TEST ("C94002D", "DEPENDENCY IS INDEPENDENT OF WHERE ACCESS " &
+ "VARIABLE IS DECLARED");
+
+BLOCK1 :
+ DECLARE
+ POINTER_TT1 : ATT1 := NEW TT1;
+ BEGIN
+ OUTER_TT1 := POINTER_TT1;
+ POINTER_TT1.ALL.E1;
+ END BLOCK1; -- MAY DEADLOCK HERE IF INCORRECT DEPENDENCY
+ -- RULE IS IMPLEMENTED.
+
+ IF OUTER_TT1.ALL'TERMINATED THEN
+ FAILED ("NON-DEPENDENT TASK IS TERMINATED " &
+ "IMMEDIATELY AFTER ENCLOSING UNIT HAS " &
+ "BEEN COMPLETED");
+ END IF;
+
+ OUTER_TT1.E2; -- RELEASE TASK
+
+ RESULT;
+
+END C94002D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002e.ada b/gcc/testsuite/ada/acats/tests/c9/c94002e.ada
new file mode 100644
index 000000000..940fd3289
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94002e.ada
@@ -0,0 +1,207 @@
+-- C94002E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL
+-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS
+-- TO TERMINATE.
+
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK.
+-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM.
+-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY.
+
+-- JRK 10/8/81
+-- SPS 11/2/82
+-- SPS 11/21/82
+-- JRK 11/29/82
+-- TBN 1/20/86 RENAMED FROM C94006A-B.ADA. LOWERED THE DELAY VALUES
+-- AND MODIFIED THE COMMENTS.
+-- JRK 5/1/86 IMPROVED ERROR RECOVERY LOGIC.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94002E IS
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ BEGIN
+ ACCEPT E;
+ ACCEPT E;
+ END TT;
+
+
+BEGIN
+ TEST ("C94002E", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " &
+ "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " &
+ "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " &
+ "TERMINATE");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE A_T IS ACCESS TT;
+ A1 : A_T;
+
+ BEGIN -- (A)
+
+ DECLARE
+ A2 : A_T;
+ BEGIN
+ A2 := NEW TT;
+ A2.ALL.E;
+ A1 := A2;
+ END;
+
+ IF A1.ALL'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)");
+ ELSE A1.ALL.E;
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ TYPE ART IS ACCESS RT;
+ AR1 : ART;
+
+ PROCEDURE P (AR : OUT ART) IS
+ AR2 : ART;
+ BEGIN
+ AR2 := NEW RT;
+ AR2.T.E;
+ AR := AR2;
+ END P;
+
+ BEGIN
+ P (AR1);
+
+ IF AR1.T'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " &
+ "- (B)");
+ ELSE AR1.T.E;
+ END IF;
+
+ RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ I := F;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60; -- DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+
+ LOOP_COUNT1 : INTEGER := 0;
+ CUT_OFF1 : CONSTANT := 60; -- DELAY.
+
+ TYPE RAT;
+ TYPE ARAT IS ACCESS RAT;
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RAT IS
+ RECORD
+ A : ARAT;
+ T : ARR;
+ END RECORD;
+ ARA1 : ARAT;
+
+ TASK TSK1 IS
+ ENTRY ENT1 (ARA : OUT ARAT);
+ END TSK1;
+
+ TASK BODY TSK1 IS
+ ARA2 : ARAT;
+ BEGIN
+ ARA2 := NEW RAT;
+ ARA2.T(1).E;
+ ACCEPT ENT1 (ARA : OUT ARAT) DO
+ ARA := ARA2;
+ END ENT1;
+ END TSK1;
+
+ BEGIN
+ TSK1.ENT1 (ARA1);
+
+ WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT1 := LOOP_COUNT1 + 1;
+ END LOOP;
+
+ IF LOOP_COUNT1 >= CUT_OFF1 THEN
+ FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " &
+ "WITHIN ONE MINUTE - (C)");
+ END IF;
+
+ IF ARA1.T(1)'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " &
+ "- (C)");
+ ELSE ARA1.T(1).E;
+ END IF;
+ END TSK;
+
+ BEGIN -- (C)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 2.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " &
+ "TWO MINUTES - (C)");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+END C94002E;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002f.ada b/gcc/testsuite/ada/acats/tests/c9/c94002f.ada
new file mode 100644
index 000000000..47f0b4df2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94002f.ada
@@ -0,0 +1,227 @@
+-- C94002F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL
+-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS
+-- TO TERMINATE IF AN EXCEPTION IS RAISED AND HANDLED IN THE
+-- NON-MASTER UNIT.
+
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK.
+-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM.
+-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY.
+
+-- TBN 1/20/86
+-- JRK 5/1/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION HANDLING.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94002F IS
+
+ MY_EXCEPTION : EXCEPTION;
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ BEGIN
+ ACCEPT E;
+ ACCEPT E;
+ END TT;
+
+
+BEGIN
+ TEST ("C94002F", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " &
+ "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " &
+ "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " &
+ "TERMINATE IF AN EXCEPTION IS RAISED AND " &
+ "HANDLED IN THE NON-MASTER UNIT");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE A_T IS ACCESS TT;
+ A1 : A_T;
+
+ BEGIN -- (A)
+
+ DECLARE
+ A2 : A_T;
+ BEGIN
+ A2 := NEW TT;
+ A2.ALL.E;
+ A1 := A2;
+ RAISE MY_EXCEPTION;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION IN (A)");
+ END;
+
+ IF A1.ALL'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)");
+ ELSE A1.ALL.E;
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ TYPE ART IS ACCESS RT;
+ AR1 : ART;
+
+ PROCEDURE P (AR : OUT ART) IS
+ AR2 : ART;
+ BEGIN
+ AR2 := NEW RT;
+ AR2.T.E;
+ AR := AR2;
+ RAISE MY_EXCEPTION;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION IN (B)");
+ END P;
+
+ BEGIN
+ P (AR1);
+
+ IF AR1.T'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " &
+ "- (B)");
+ ELSE AR1.T.E;
+ END IF;
+
+ RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ I := F;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60; -- DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+
+ LOOP_COUNT1 : INTEGER := 0;
+ CUT_OFF1 : CONSTANT := 60; -- DELAY.
+
+ TYPE RAT;
+ TYPE ARAT IS ACCESS RAT;
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RAT IS
+ RECORD
+ A : ARAT;
+ T : ARR;
+ END RECORD;
+ ARA1 : ARAT;
+
+ TASK TSK1 IS
+ ENTRY ENT1 (ARA : OUT ARAT);
+ END TSK1;
+
+ TASK BODY TSK1 IS
+ ARA2 : ARAT;
+ BEGIN
+ ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1).
+ ARA2.T(1).E;
+ ACCEPT ENT1 (ARA : OUT ARAT) DO
+ ARA := ARA2;
+ END ENT1;
+ RAISE MY_EXCEPTION;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION IN (C)");
+ END TSK1;
+
+ BEGIN
+ TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T.
+
+ WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT1 := LOOP_COUNT1 + 1;
+ END LOOP;
+
+ IF LOOP_COUNT1 >= CUT_OFF1 THEN
+ FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " &
+ "WITHIN ONE MINUTE - (C)");
+ END IF;
+
+ IF ARA1.T(1)'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " &
+ "- (C)");
+ ELSE ARA1.T(1).E;
+ END IF;
+ END TSK;
+
+ BEGIN -- (C)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 2.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " &
+ "TWO MINUTES - (C)");
+ END IF;
+
+ END; -- (C)
+
+ ---------------------------------------------------------------
+
+ RESULT;
+END C94002F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002g.ada b/gcc/testsuite/ada/acats/tests/c9/c94002g.ada
new file mode 100644
index 000000000..1b6108fe5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94002g.ada
@@ -0,0 +1,350 @@
+-- C94002G.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL
+-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED
+-- TASKS TO TERMINATE IF AN EXCEPTION IS RAISED BUT NOT HANDLED IN
+-- THE NON-MASTER UNIT.
+
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK.
+-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM.
+-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY, NOT
+-- DURING RENDEZVOUS.
+-- (D) A LIMITED PRIVATE TASK ALLOCATOR, IN A TASK BODY, DURING
+-- RENDEZVOUS.
+
+-- HISTORY:
+-- TBN 01/20/86 CREATED ORIGINAL TEST.
+-- JRK 05/01/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION
+-- HANDLING. ADDED CASE (D).
+-- BCB 09/24/87 ADDED A RETURN STATEMENT TO THE HANDLER FOR OTHERS
+-- IN FUNCTION F, CASE B.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94002G IS
+
+ MY_EXCEPTION : EXCEPTION;
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ BEGIN
+ ACCEPT E;
+ ACCEPT E;
+ END TT;
+
+
+BEGIN
+ TEST ("C94002G", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " &
+ "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " &
+ "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " &
+ "TERMINATE IF AN EXCEPTION IS RAISED BUT NOT " &
+ "HANDLED IN THE NON-MASTER UNIT");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE A_T IS ACCESS TT;
+ A1 : A_T;
+
+ BEGIN -- (A)
+
+ DECLARE
+ A2 : A_T;
+ BEGIN
+ A2 := NEW TT;
+ A2.ALL.E;
+ A1 := A2;
+ RAISE MY_EXCEPTION;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)");
+ END;
+
+ ABORT A1.ALL;
+
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF A1.ALL'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - " &
+ "(A)");
+ ELSE A1.ALL.E;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION IN (A)");
+ IF A1 /= NULL THEN
+ ABORT A1.ALL;
+ END IF;
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+ TYPE ART IS ACCESS RT;
+ AR1 : ART;
+
+ PROCEDURE P IS
+ AR2 : ART;
+ BEGIN
+ AR2 := NEW RT;
+ AR2.T.E;
+ AR1 := AR2;
+ RAISE MY_EXCEPTION;
+ FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)");
+ END P;
+
+ BEGIN
+ P;
+ ABORT AR1.T;
+ RETURN 0;
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF AR1.T'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY " &
+ "TERMINATED - (B)");
+ ELSE AR1.T.E;
+ END IF;
+ RETURN 0;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION IN (B)");
+ IF AR1 /= NULL THEN
+ ABORT AR1.T;
+ END IF;
+ RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ I := F;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60; -- DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+
+ LOOP_COUNT1 : INTEGER := 0;
+ CUT_OFF1 : CONSTANT := 60; -- DELAY.
+
+ TYPE RAT;
+ TYPE ARAT IS ACCESS RAT;
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RAT IS
+ RECORD
+ A : ARAT;
+ T : ARR;
+ END RECORD;
+ ARA1 : ARAT;
+
+ TASK TSK1 IS
+ ENTRY ENT1 (ARA : OUT ARAT);
+ END TSK1;
+
+ TASK BODY TSK1 IS
+ ARA2 : ARAT;
+ BEGIN
+ ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1).
+ ARA2.T(1).E;
+ ACCEPT ENT1 (ARA : OUT ARAT) DO
+ ARA := ARA2;
+ END ENT1;
+ RAISE MY_EXCEPTION; -- NOT PROPOGATED.
+ FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)");
+ END TSK1;
+
+ BEGIN
+ TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T.
+
+ WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT1 := LOOP_COUNT1 + 1;
+ END LOOP;
+
+ IF LOOP_COUNT1 >= CUT_OFF1 THEN
+ FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " &
+ "WITHIN ONE MINUTE - (C)");
+ END IF;
+
+ IF ARA1.T(1)'TERMINATED THEN
+ FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " &
+ "- (C)");
+ ELSE ARA1.T(1).E;
+ END IF;
+ END TSK;
+
+ BEGIN -- (C)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 2.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " &
+ "TWO MINUTES - (C)");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ LOOP_COUNT : INTEGER := 0;
+ CUT_OFF : CONSTANT := 60; -- DELAY.
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+
+ LOOP_COUNT1 : INTEGER := 0;
+ CUT_OFF1 : CONSTANT := 60; -- DELAY.
+
+ PACKAGE PKG IS
+ TYPE LPT IS LIMITED PRIVATE;
+ PROCEDURE CALL (X : LPT);
+ PROCEDURE KILL (X : LPT);
+ FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN;
+ PRIVATE
+ TYPE LPT IS NEW TT;
+ END PKG;
+
+ USE PKG;
+
+ TYPE ALPT IS ACCESS LPT;
+ ALP1 : ALPT;
+
+ PACKAGE BODY PKG IS
+ PROCEDURE CALL (X : LPT) IS
+ BEGIN
+ X.E;
+ END CALL;
+
+ PROCEDURE KILL (X : LPT) IS
+ BEGIN
+ ABORT X;
+ END KILL;
+
+ FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X'TERMINATED;
+ END TERMINATED;
+ END PKG;
+
+ TASK TSK1 IS
+ ENTRY ENT1 (ALP : OUT ALPT);
+ ENTRY DIE;
+ END TSK1;
+
+ TASK BODY TSK1 IS
+ ALP2 : ALPT;
+ BEGIN
+ ALP2 := NEW LPT; -- INITIATE TASK ALP2.ALL.
+ CALL (ALP2.ALL);
+ ACCEPT ENT1 (ALP : OUT ALPT) DO
+ ALP := ALP2;
+ END ENT1;
+ ACCEPT DIE DO
+ RAISE MY_EXCEPTION; -- PROPOGATED.
+ FAILED ("MY_EXCEPTION WAS NOT RAISED IN (D)");
+ END DIE;
+ END TSK1;
+
+ BEGIN
+ TSK1.ENT1 (ALP1); -- ALP1.ALL BECOMES ALIAS FOR ALP2.ALL.
+ TSK1.DIE;
+ FAILED ("MY_EXCEPTION WAS NOT PROPOGATED TO CALLING " &
+ "TASK - (D)");
+ KILL (ALP1.ALL);
+ ABORT TSK1;
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ WHILE NOT TSK1'TERMINATED AND
+ LOOP_COUNT1 < CUT_OFF1 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ LOOP_COUNT1 := LOOP_COUNT1 + 1;
+ END LOOP;
+
+ IF LOOP_COUNT1 >= CUT_OFF1 THEN
+ FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " &
+ "WITHIN ONE MINUTE - (D)");
+ END IF;
+
+ IF TERMINATED (ALP1.ALL) THEN
+ FAILED ("ALLOCATED TASK PREMATURELY " &
+ "TERMINATED - (D)");
+ ELSE CALL (ALP1.ALL);
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION IN (D)");
+ IF ALP1 /= NULL THEN
+ KILL (ALP1.ALL);
+ END IF;
+ ABORT TSK1;
+ END TSK;
+
+ BEGIN -- (D)
+
+ WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP
+ DELAY 2.0 * Impdef.One_Second;
+ LOOP_COUNT := LOOP_COUNT + 1;
+ END LOOP;
+
+ IF LOOP_COUNT >= CUT_OFF THEN
+ FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " &
+ "TWO MINUTES - (D)");
+ END IF;
+
+ END; -- (D)
+
+ --------------------------------------------------
+
+ RESULT;
+END C94002G;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004a.ada b/gcc/testsuite/ada/acats/tests/c9/c94004a.ada
new file mode 100644
index 000000000..b895f8c87
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94004a.ada
@@ -0,0 +1,95 @@
+-- C94004A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT
+-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY
+-- MAIN PROGRAM TERMINATION.
+
+-- CASE A: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN
+-- PROGRAM.
+
+-- JRK 10/8/81
+-- SPS 11/21/82
+-- JBG 12/6/84
+-- JRK 11/21/85 RENAMED FROM C94004A-B.ADA; REVISED ACCORDING TO
+-- AI-00399.
+-- JRK 10/24/86 RENAMED FROM E94004A-B.ADA; REVISED ACCORDING TO
+-- REVISED AI-00399.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+PACKAGE C94004A_PKG IS
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+END C94004A_PKG;
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PRAGMA ELABORATE (REPORT);
+PACKAGE BODY C94004A_PKG IS
+
+ TASK BODY TT IS
+ I : INTEGER := IDENT_INT (120);
+ BEGIN
+ ACCEPT E;
+ COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES");
+ DELAY DURATION(I) * Impdef.One_Second;
+ -- MAIN PROGRAM SHOULD NOW BE TERMINATED.
+ RESULT;
+ END TT;
+
+END C94004A_PKG;
+
+WITH C94004A_PKG; USE C94004A_PKG;
+PRAGMA ELABORATE (C94004A_PKG);
+PACKAGE C94004A_TASK IS
+ T : TT;
+END;
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+WITH C94004A_TASK;
+PROCEDURE C94004A IS
+
+
+BEGIN
+ TEST ("C94004A", "CHECK THAT A MAIN PROGRAM TERMINATES " &
+ "WITHOUT WAITING FOR TASKS THAT DEPEND " &
+ "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " &
+ "CONTINUE TO EXECUTE");
+
+ COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " &
+ "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES");
+
+ C94004A_TASK.T.E; -- ALLOW TASK TO PROCEED.
+ IF C94004A_TASK.T'TERMINATED THEN
+ FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED");
+ END IF;
+
+ -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK.
+
+END C94004A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004b.ada b/gcc/testsuite/ada/acats/tests/c9/c94004b.ada
new file mode 100644
index 000000000..3a578fd8b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94004b.ada
@@ -0,0 +1,97 @@
+-- C94004B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT
+-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY
+-- MAIN PROGRAM TERMINATION.
+
+-- CASE B: ACCESS TO TASK TYPE DECLARED IN LIBRARY PACKAGE; TASK
+-- ACTIVATED IN MAIN PROGRAM.
+
+-- JRK 10/8/81
+-- SPS 11/21/82
+-- JBG 12/6/84
+-- JRK 11/21/85 RENAMED FROM C94004B-B.ADA; REVISED ACCORDING TO
+-- AI-00399.
+-- JRK 10/24/86 RENAMED FROM E94004B-B.ADA; REVISED ACCORDING TO
+-- REVISED AI-00399.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+PACKAGE C94004B_PKG IS
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+END C94004B_PKG;
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PRAGMA ELABORATE (REPORT);
+PACKAGE BODY C94004B_PKG IS
+
+ TASK BODY TT IS
+ I : INTEGER := IDENT_INT (120);
+ BEGIN
+ ACCEPT E;
+ COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES");
+ DELAY DURATION(I) * Impdef.One_Second;
+ -- MAIN PROGRAM SHOULD NOW BE TERMINATED.
+ RESULT;
+ END TT;
+
+END C94004B_PKG;
+
+WITH C94004B_PKG; USE C94004B_PKG;
+PRAGMA ELABORATE (C94004B_PKG);
+PACKAGE C94004B_TASK IS
+ TYPE ACC_TASK IS ACCESS C94004B_PKG.TT;
+END;
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+WITH C94004B_TASK; WITH C94004B_PKG;
+PROCEDURE C94004B IS
+
+ T : C94004B_TASK.ACC_TASK;
+
+BEGIN
+ TEST ("C94004B", "CHECK THAT A MAIN PROGRAM TERMINATES " &
+ "WITHOUT WAITING FOR TASKS THAT DEPEND " &
+ "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " &
+ "CONTINUE TO EXECUTE");
+
+ COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " &
+ "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES");
+
+ T := NEW C94004B_PKG.TT;
+ T.E; -- ALLOW TASK TO PROCEED.
+ IF T'TERMINATED THEN
+ FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED");
+ END IF;
+
+ -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK.
+
+END C94004B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004c.ada b/gcc/testsuite/ada/acats/tests/c9/c94004c.ada
new file mode 100644
index 000000000..321bfee72
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94004c.ada
@@ -0,0 +1,104 @@
+-- C94004C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT
+-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY
+-- MAIN PROGRAM TERMINATION.
+
+-- CASE C: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN PROGRAM
+-- AND WAITING AT A SELECTIVE WAIT WITH TERMINATE.
+
+-- JRK 10/8/81
+-- SPS 11/21/82
+-- JBG 12/6/84
+-- JRK 11/21/85 RENAMED FROM C94004C-B.ADA; REVISED ACCORDING TO
+-- AI-00399.
+-- JRK 10/24/86 RENAMED FROM E94004C-B.ADA; REVISED ACCORDING TO
+-- REVISED AI-00399.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+PACKAGE C94004C_PKG IS
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+END C94004C_PKG;
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PRAGMA ELABORATE (REPORT);
+PACKAGE BODY C94004C_PKG IS
+
+ TASK BODY TT IS
+ I : INTEGER := IDENT_INT (120);
+ BEGIN
+ ACCEPT E;
+ COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES");
+ DELAY DURATION(I) * Impdef.One_Second;
+ -- MAIN PROGRAM SHOULD NOW BE TERMINATED.
+ RESULT;
+ -- USE LOOP FOR SELECTIVE WAIT WITH TERMINATE.
+ LOOP
+ SELECT
+ ACCEPT E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ -- FAILS IF JOB HANGS UP WITHOUT TERMINATING.
+ END TT;
+
+END C94004C_PKG;
+
+WITH C94004C_PKG; USE C94004C_PKG;
+PRAGMA ELABORATE (C94004C_PKG);
+PACKAGE C94004C_TASK IS
+ T : TT;
+END;
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+WITH C94004C_TASK;
+PROCEDURE C94004C IS
+
+
+BEGIN
+ TEST ("C94004C", "CHECK THAT A MAIN PROGRAM TERMINATES " &
+ "WITHOUT WAITING FOR TASKS THAT DEPEND " &
+ "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " &
+ "CONTINUE TO EXECUTE");
+
+ COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " &
+ "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES");
+
+ C94004C_TASK.T.E; -- ALLOW TASK TO PROCEED.
+ IF C94004C_TASK.T'TERMINATED THEN
+ FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED");
+ END IF;
+
+ -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK.
+
+END C94004C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94005a.ada b/gcc/testsuite/ada/acats/tests/c9/c94005a.ada
new file mode 100644
index 000000000..71c5846f4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94005a.ada
@@ -0,0 +1,90 @@
+-- C94005A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, A MAIN
+-- PROGRAM THAT DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR
+-- TERMINATION OF SUCH OBJECTS.
+
+-- THIS TEST CONTAINS RACE CONDITIONS.
+
+-- JRK 10/8/81
+-- SPS 11/21/82
+-- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005A_PKG.
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+
+WITH SYSTEM; USE SYSTEM;
+PACKAGE C94005A_PKG IS
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+END C94005A_PKG;
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PACKAGE BODY C94005A_PKG IS
+
+ TASK BODY TT IS
+ I : INTEGER := IDENT_INT (0);
+ BEGIN
+ ACCEPT E;
+ FOR J IN 1..60 LOOP
+ I := IDENT_INT (I);
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+ RESULT; -- FAILURE IF THIS MESSAGE IS NOT WRITTEN.
+ END TT;
+
+END C94005A_PKG;
+
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+WITH C94005A_PKG;
+PROCEDURE C94005A IS
+
+ T : C94005A_PKG.TT;
+
+
+BEGIN
+ TEST ("C94005A", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " &
+ "LIBRARY PACKAGE, A MAIN PROGRAM THAT " &
+ "DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR " &
+ "TERMINATION OF SUCH OBJECTS");
+
+ COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " &
+ "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES");
+
+ T.E;
+
+ IF T'TERMINATED THEN
+ COMMENT ("TEST INCONCLUSIVE BECAUSE TASK T PREMATURELY " &
+ "TERMINATED");
+ END IF;
+
+ -- TASK T SHOULD WRITE THE RESULT MESSAGE.
+
+END C94005A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94005b.ada b/gcc/testsuite/ada/acats/tests/c9/c94005b.ada
new file mode 100644
index 000000000..2a481b313
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94005b.ada
@@ -0,0 +1,168 @@
+-- C94005B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, ANY
+-- BLOCKS, SUBPROGRAMS, OR TASKS THAT DECLARE OBJECTS OF THAT TYPE
+-- DO WAIT FOR TERMINATION OF SUCH OBJECTS.
+-- SUBTESTS ARE:
+-- (A) IN A MAIN PROGRAM BLOCK.
+-- (B) IN A LIBRARY FUNCTION.
+-- (C) IN A MAIN PROGRAM TASK BODY.
+
+-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS.
+
+-- JRK 10/8/81
+-- SPS 11/2/82
+-- SPS 11/21/82
+-- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005B_PKG.
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+
+WITH SYSTEM; USE SYSTEM;
+PACKAGE C94005B_PKG IS
+
+ GLOBAL : INTEGER;
+
+ TASK TYPE TT IS
+ ENTRY E (I : INTEGER);
+ END TT;
+
+END C94005B_PKG;
+
+with Impdef;
+PACKAGE BODY C94005B_PKG IS
+
+ TASK BODY TT IS
+ LOCAL : INTEGER;
+ BEGIN
+ ACCEPT E (I : INTEGER) DO
+ LOCAL := I;
+ END E;
+ DELAY 60.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY
+ -- AT THIS POINT, IT WILL RECEIVE CONTROL AND
+ -- TERMINATE IF THE ERROR IS PRESENT.
+ GLOBAL := LOCAL;
+ END TT;
+
+END C94005B_PKG;
+
+
+WITH REPORT; USE REPORT;
+WITH C94005B_PKG; USE C94005B_PKG;
+FUNCTION F RETURN INTEGER IS
+
+ T : TT;
+
+BEGIN
+
+ T.E (IDENT_INT(2));
+ RETURN 0;
+
+END F;
+
+with Impdef;
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+WITH C94005B_PKG; USE C94005B_PKG;
+WITH F;
+PROCEDURE C94005B IS
+
+
+BEGIN
+ TEST ("C94005B", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " &
+ "LIBRARY PACKAGE, ANY BLOCKS, SUBPROGRAMS, OR " &
+ "TASKS THAT DECLARE OBJECTS OF THAT TYPE DO " &
+ "WAIT FOR TERMINATION OF SUCH OBJECTS");
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (A)
+
+ T : TT;
+
+ BEGIN -- (A)
+
+ T.E (IDENT_INT(1));
+
+ END; -- (A)
+
+ IF GLOBAL /= 1 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "BLOCK EXIT - (A)");
+ END IF;
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (B)
+
+ I : INTEGER;
+
+ BEGIN -- (B)
+
+ I := F ;
+
+ IF GLOBAL /= 2 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "FUNCTION EXIT - (B)");
+ END IF;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ GLOBAL := IDENT_INT (0);
+
+ DECLARE -- (C)
+
+ TASK TSK IS
+ ENTRY ENT;
+ END TSK;
+
+ TASK BODY TSK IS
+ T : TT;
+ BEGIN
+ T.E (IDENT_INT(3));
+ END TSK;
+
+ BEGIN -- (C)
+
+ WHILE NOT TSK'TERMINATED LOOP
+ DELAY 0.1 * Impdef.One_Second;
+ END LOOP;
+
+ IF GLOBAL /= 3 THEN
+ FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " &
+ "TASK EXIT - (C)");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+END C94005B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94006a.ada b/gcc/testsuite/ada/acats/tests/c9/c94006a.ada
new file mode 100644
index 000000000..cac5fc6e0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94006a.ada
@@ -0,0 +1,136 @@
+-- C94006A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A DECLARATION THAT RENAMES A TASK DOES NOT CREATE A NEW
+-- MASTER FOR THE TASK.
+
+-- TBN 9/17/86
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94006A IS
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TASK BODY TT IS
+ BEGIN
+ SELECT
+ ACCEPT E;
+ OR
+ DELAY 30.0 * Impdef.One_Long_Second;
+ END SELECT;
+ END TT;
+
+
+BEGIN
+ TEST ("C94006A", "CHECK THAT A DECLARATION THAT RENAMES A TASK " &
+ "DOES NOT CREATE A NEW MASTER FOR THE TASK");
+
+ -------------------------------------------------------------------
+ DECLARE
+ T1 : TT;
+ BEGIN
+ DECLARE
+ RENAME_TASK : TT RENAMES T1;
+ BEGIN
+ NULL;
+ END;
+ IF T1'TERMINATED THEN
+ FAILED ("TASK DEPENDENT ON WRONG UNIT - 1");
+ ELSE
+ T1.E;
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+
+ DECLARE
+ T2 : TT;
+
+ PACKAGE P IS
+ Q : TT RENAMES T2;
+ END P;
+
+ PACKAGE BODY P IS
+ BEGIN
+ NULL;
+ END P;
+
+ USE P;
+ BEGIN
+ IF Q'TERMINATED THEN
+ FAILED ("TASK DEPENDENT ON WRONG UNIT - 2");
+ ELSE
+ Q.E;
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+
+ DECLARE
+ TYPE ACC_TT IS ACCESS TT;
+ P1 : ACC_TT;
+ BEGIN
+ DECLARE
+ RENAME_ACCESS : ACC_TT RENAMES P1;
+ BEGIN
+ RENAME_ACCESS := NEW TT;
+ END;
+ IF P1'TERMINATED THEN
+ FAILED ("TASK DEPENDENT ON WRONG UNIT - 3");
+ ELSE
+ P1.E;
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+
+ DECLARE
+ TYPE ACC_TT IS ACCESS TT;
+ P2 : ACC_TT;
+
+ PACKAGE Q IS
+ RENAME_ACCESS : ACC_TT RENAMES P2;
+ END Q;
+
+ PACKAGE BODY Q IS
+ BEGIN
+ RENAME_ACCESS := NEW TT;
+ END Q;
+
+ USE Q;
+ BEGIN
+ IF RENAME_ACCESS'TERMINATED THEN
+ FAILED ("TASK DEPENDENT ON WRONG UNIT - 4");
+ ELSE
+ RENAME_ACCESS.E;
+ END IF;
+ END;
+
+ RESULT;
+END C94006A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94007a.ada b/gcc/testsuite/ada/acats/tests/c9/c94007a.ada
new file mode 100644
index 000000000..e0a2c3f76
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94007a.ada
@@ -0,0 +1,270 @@
+-- C94007A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT A TASK THAT IS DECLARED IN A NON-LIBRARY PACKAGE
+-- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE,
+-- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY,
+-- OR TASK BODY.
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK OBJECT, IN A VISIBLE PART, IN A BLOCK.
+-- (B) AN ARRAY OF TASK OBJECT, IN A PRIVATE PART, IN A FUNCTION.
+-- (C) AN ARRAY OF RECORD OF TASK OBJECT, IN A PACKAGE BODY,
+-- IN A TASK BODY.
+
+-- HISTORY:
+-- JRK 10/13/81
+-- SPS 11/21/82
+-- DHH 09/07/88 REVISED HEADER, ADDED EXCEPTION HANDLERS ON OUTER
+-- BLOCKS, AND ADDED CASE TO INSURE THAT LEAVING A
+-- PACKAGE VIA AN EXCEPTION WOULD NOT ABORT TASKS.
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94007A IS
+
+ TASK TYPE SYNC IS
+ ENTRY ID (C : CHARACTER);
+ ENTRY INNER;
+ ENTRY OUTER;
+ END SYNC;
+
+ TASK BODY SYNC IS
+ ID_C : CHARACTER;
+ BEGIN
+ ACCEPT ID (C : CHARACTER) DO
+ ID_C := C;
+ END ID;
+ DELAY 1.0 * Impdef.One_Second;
+ SELECT
+ ACCEPT OUTER;
+ OR
+ DELAY 120.0 * Impdef.One_Second;
+ FAILED ("PROBABLY BLOCKED - (" & ID_C & ')');
+ END SELECT;
+ ACCEPT INNER;
+ END SYNC;
+
+
+BEGIN
+ TEST ("C94007A", "CHECK THAT A TASK THAT IS DECLARED IN A " &
+ "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " &
+ "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " &
+ "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " &
+ "BODY, OR TASK BODY");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ S : SYNC;
+
+ BEGIN -- (A)
+
+ S.ID ('A');
+
+ DECLARE
+
+ PACKAGE PKG IS
+ TASK T IS
+ ENTRY E;
+ END T;
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ TASK BODY T IS
+ BEGIN
+ S.INNER; -- PROBABLE INNER BLOCK POINT.
+ END T;
+ END PKG; -- PROBABLE OUTER BLOCK POINT.
+
+ BEGIN
+
+ S.OUTER;
+
+ EXCEPTION
+ WHEN TASKING_ERROR => NULL;
+ END;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED EXCEPTION RAISED - A");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ S : SYNC;
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+
+ PACKAGE PKG IS
+ PRIVATE
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+ A : ARRAY (1..1) OF TT;
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ TASK BODY TT IS
+ BEGIN
+ S.INNER; -- PROBABLE INNER BLOCK POINT.
+ END TT;
+ END PKG; -- PROBABLE OUTER BLOCK POINT.
+
+ BEGIN -- F
+
+ S.OUTER;
+ RETURN 0;
+
+ EXCEPTION
+ WHEN TASKING_ERROR => RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ S.ID ('B');
+ I := F;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED EXCEPTION RAISED - B");
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ S : SYNC;
+
+ BEGIN -- (C)
+
+ S.ID ('C');
+
+ DECLARE
+
+ TASK TSK IS
+ END TSK;
+
+ TASK BODY TSK IS
+
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+
+ AR : ARRAY (1..1) OF RT;
+
+ TASK BODY TT IS
+ BEGIN
+ S.INNER; -- PROBABLE INNER BLOCK POINT.
+ END TT;
+ END PKG; -- PROBABLE OUTER BLOCK POINT.
+
+ BEGIN -- TSK
+
+ S.OUTER;
+
+ EXCEPTION
+ WHEN TASKING_ERROR => NULL;
+ END TSK;
+
+ BEGIN
+ NULL;
+ END;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED EXCEPTION RAISED - C");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ GLOBAL : INTEGER := IDENT_INT(5);
+
+ BEGIN -- (D)
+
+ DECLARE
+
+ PACKAGE PKG IS
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK T1 IS
+ END T1;
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E DO
+ RAISE CONSTRAINT_ERROR;
+ END E;
+ END T;
+
+ TASK BODY T1 IS
+ BEGIN
+ DELAY 120.0 * Impdef.One_Second;
+ GLOBAL := IDENT_INT(1);
+ END T1;
+
+ BEGIN
+ T.E;
+
+ END PKG;
+ USE PKG;
+ BEGIN
+ NULL;
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF GLOBAL /= IDENT_INT(1) THEN
+ FAILED("TASK NOT COMPLETED");
+ END IF;
+
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED EXCEPTION RAISED - D");
+ END; -- (D)
+
+ RESULT;
+END C94007A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94007b.ada b/gcc/testsuite/ada/acats/tests/c9/c94007b.ada
new file mode 100644
index 000000000..87e45b352
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94007b.ada
@@ -0,0 +1,224 @@
+-- C94007B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK THAT IS ALLOCATED IN A NON-LIBRARY PACKAGE
+-- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE,
+-- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY,
+-- OR TASK BODY.
+-- SUBTESTS ARE:
+-- (A) A SIMPLE TASK ALLOCATOR, IN A VISIBLE PART, IN A BLOCK.
+-- (B) A RECORD OF TASK ALLOCATOR, IN A PRIVATE PART, IN A FUNCTION.
+-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY,
+-- IN A TASK BODY.
+
+-- JRK 10/16/81
+-- SPS 11/2/82
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94007B IS
+
+ TASK TYPE SYNC IS
+ ENTRY ID (C : CHARACTER);
+ ENTRY INNER;
+ ENTRY OUTER;
+ END SYNC;
+
+ TASK BODY SYNC IS
+ ID_C : CHARACTER;
+ BEGIN
+ ACCEPT ID (C : CHARACTER) DO
+ ID_C := C;
+ END ID;
+ DELAY 1.0 * Impdef.One_Second;
+ SELECT
+ ACCEPT OUTER;
+ OR
+ DELAY 120.0 * Impdef.One_Second;
+ FAILED ("PROBABLY BLOCKED - (" & ID_C & ')');
+ END SELECT;
+ ACCEPT INNER;
+ END SYNC;
+
+
+BEGIN
+ TEST ("C94007B", "CHECK THAT A TASK THAT IS ALLOCATED IN A " &
+ "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " &
+ "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " &
+ "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " &
+ "BODY, OR TASK BODY");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ S : SYNC;
+
+ BEGIN -- (A)
+
+ S.ID ('A');
+
+ DECLARE
+
+ PACKAGE PKG IS
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+ TYPE A_T IS ACCESS TT;
+ A : A_T;
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ TASK BODY TT IS
+ BEGIN
+ S.INNER; -- PROBABLE INNER BLOCK POINT.
+ END TT;
+ BEGIN
+ A := NEW TT;
+ END PKG; -- PROBABLE OUTER BLOCK POINT.
+
+ BEGIN
+
+ S.OUTER;
+
+ EXCEPTION
+ WHEN TASKING_ERROR => NULL;
+ END;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ S : SYNC;
+
+ I : INTEGER;
+
+ FUNCTION F RETURN INTEGER IS
+
+ PACKAGE PKG IS
+ PRIVATE
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TYPE RT IS
+ RECORD
+ T : TT;
+ END RECORD;
+
+ TYPE ART IS ACCESS RT;
+
+ AR : ART;
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ TASK BODY TT IS
+ BEGIN
+ S.INNER; -- PROBABLE INNER BLOCK POINT.
+ END TT;
+ BEGIN
+ AR := NEW RT;
+ END PKG; -- PROBABLE OUTER BLOCK POINT.
+
+ BEGIN -- F
+
+ S.OUTER;
+ RETURN 0;
+
+ EXCEPTION
+ WHEN TASKING_ERROR => RETURN 0;
+ END F;
+
+ BEGIN -- (B)
+
+ S.ID ('B');
+ I := F ;
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ S : SYNC;
+
+ BEGIN -- (C)
+
+ S.ID ('C');
+
+ DECLARE
+
+ TASK TSK IS
+ END TSK;
+
+ TASK BODY TSK IS
+
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TYPE ARR IS ARRAY (1..1) OF TT;
+ TYPE RAT IS
+ RECORD
+ T : ARR;
+ END RECORD;
+
+ TYPE ARAT IS ACCESS RAT;
+
+ ARA : ARAT;
+
+ TASK BODY TT IS
+ BEGIN
+ S.INNER; -- PROBABLE INNER BLOCK POINT.
+ END TT;
+ BEGIN
+ ARA := NEW RAT;
+ END PKG; -- PROBABLE OUTER BLOCK POINT.
+
+ BEGIN -- TSK
+
+ S.OUTER;
+
+ EXCEPTION
+ WHEN TASKING_ERROR => NULL;
+ END TSK;
+
+ BEGIN
+ NULL;
+ END;
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+END C94007B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008a.ada b/gcc/testsuite/ada/acats/tests/c9/c94008a.ada
new file mode 100644
index 000000000..90b31d315
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94008a.ada
@@ -0,0 +1,61 @@
+-- C94008A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE
+-- DOES N O T TERMINATE WHILE THE UNIT THE TASK DEPENDS ON
+-- HAS NOT COMPLETED ITS EXECUTION.
+
+-- WEI 3/ 4/82
+-- TBN 11/25/85 RENAMED FROM C940BAA-B.ADA.
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C94008A IS
+BEGIN
+ TEST ("C94008A", "TERMINATION WHILE WAITING AT " &
+ "AN OPEN TERMINATE ALTERNATIVE");
+
+BLOCK1 :
+ DECLARE
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ SELECT
+ WHEN TRUE => TERMINATE;
+ OR WHEN FALSE => ACCEPT E1;
+ END SELECT;
+ END T1;
+ BEGIN -- BLOCK1
+ IF T1'TERMINATED THEN
+ FAILED ("TASK T1 TERMINATED BEFORE OUTER UNIT HAS " &
+ "BEEN LEFT");
+ END IF;
+ END BLOCK1;
+
+ RESULT;
+
+END C94008A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008b.ada b/gcc/testsuite/ada/acats/tests/c9/c94008b.ada
new file mode 100644
index 000000000..e72d4890e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94008b.ada
@@ -0,0 +1,81 @@
+-- C94008B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE
+-- DOES N O T TERMINATE UNTIL ALL OTHER TASKS DEPENDING ON THE SAME
+-- UNIT EITHER ARE TERMINATED OR ARE WAITING AT AN OPEN TERMINATE.
+
+-- WEI 3/ 4/82
+-- TBN 11/25/85 RENAMED FROM C940BBA-B.ADA.
+
+with Impdef;
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C94008B IS
+BEGIN
+ TEST ("C94008B", "TERMINATION WHILE WAITING AT AN OPEN TERMINATE");
+
+BLOCK1 :
+ DECLARE
+
+ TASK TYPE TT1 IS
+ ENTRY E1;
+ END TT1;
+
+ NUMB_TT1 : CONSTANT NATURAL := 3;
+ DELAY_TIME : DURATION := 0.0;
+ ARRAY_TT1 : ARRAY (1 .. NUMB_TT1) OF TT1;
+
+ TASK BODY TT1 IS
+ BEGIN
+ DELAY_TIME := DELAY_TIME + 1.0 * Impdef.One_Second;
+ DELAY DELAY_TIME;
+ FOR I IN 1 .. NUMB_TT1
+ LOOP
+ IF ARRAY_TT1 (I)'TERMINATED THEN
+ FAILED ("TOO EARLY TERMINATION OF " &
+ "TASK TT1 INDEX" & INTEGER'IMAGE(I));
+ END IF;
+ END LOOP;
+
+ SELECT
+ WHEN TRUE => TERMINATE;
+ OR WHEN FALSE => ACCEPT E1;
+ END SELECT;
+ END TT1;
+
+ BEGIN -- BLOCK1.
+ FOR I IN 1 .. NUMB_TT1
+ LOOP
+ IF ARRAY_TT1 (I)'TERMINATED THEN
+ FAILED ("TERMINATION BEFORE OUTER " &
+ "UNIT HAS BEEN LEFT OF TASK TT1 INDEX " &
+ INTEGER'IMAGE(I));
+ END IF;
+ END LOOP;
+ END BLOCK1;
+
+ RESULT;
+
+END C94008B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008c.ada b/gcc/testsuite/ada/acats/tests/c9/c94008c.ada
new file mode 100644
index 000000000..fb2eee97f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94008c.ada
@@ -0,0 +1,265 @@
+-- C94008C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT SELECT WITH TERMINATE ALTERNATIVE WORKS CORRECTLY WITH
+-- NESTED TASKS.
+
+-- THIS TEST CONTAINS RACE CONDITIONS AND USES A GENERIC INSTANCE THAT
+-- CONTAINS TASKS.
+
+-- JEAN-PIERRE ROSEN 24 FEBRUARY 1984
+-- JRK 4/7/86
+-- JBG 8/29/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94008C IS
+
+
+-- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES
+ GENERIC
+ TYPE HOLDER_TYPE IS PRIVATE;
+ TYPE VALUE_TYPE IS PRIVATE;
+ INITIAL_VALUE : HOLDER_TYPE;
+ WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE;
+ VALUE : IN HOLDER_TYPE) IS <>;
+ WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE;
+ VALUE : IN VALUE_TYPE) IS <>;
+ PACKAGE SHARED IS
+ PROCEDURE SET (VALUE : IN HOLDER_TYPE);
+ PROCEDURE UPDATE (VALUE : IN VALUE_TYPE);
+ FUNCTION GET RETURN HOLDER_TYPE;
+ END SHARED;
+
+ PACKAGE BODY SHARED IS
+ TASK SHARE IS
+ ENTRY SET (VALUE : IN HOLDER_TYPE);
+ ENTRY UPDATE (VALUE : IN VALUE_TYPE);
+ ENTRY READ (VALUE : OUT HOLDER_TYPE);
+ END SHARE;
+
+ TASK BODY SHARE IS
+ VARIABLE : HOLDER_TYPE;
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT SET (VALUE : IN HOLDER_TYPE) DO
+ SHARED.SET (VARIABLE, VALUE);
+ END SET;
+ OR
+ ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO
+ SHARED.UPDATE (VARIABLE, VALUE);
+ END UPDATE;
+ OR
+ ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO
+ VALUE := VARIABLE;
+ END READ;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END SHARE;
+
+ PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS
+ BEGIN
+ SHARE.SET (VALUE);
+ END SET;
+
+ PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS
+ BEGIN
+ SHARE.UPDATE (VALUE);
+ END UPDATE;
+
+ FUNCTION GET RETURN HOLDER_TYPE IS
+ VALUE : HOLDER_TYPE;
+ BEGIN
+ SHARE.READ (VALUE);
+ RETURN VALUE;
+ END GET;
+
+ BEGIN
+ SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE
+ END SHARED;
+
+ PACKAGE EVENTS IS
+
+ TYPE EVENT_TYPE IS
+ RECORD
+ TRACE : STRING (1..4) := "....";
+ LENGTH : NATURAL := 0;
+ END RECORD;
+
+ PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER);
+ PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE);
+ END EVENTS;
+
+ PACKAGE COUNTER IS
+ PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER);
+ PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER);
+ END COUNTER;
+
+ PACKAGE BODY COUNTER IS
+ PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS
+ BEGIN
+ VAR := VAR + VAL;
+ END UPDATE;
+
+ PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS
+ BEGIN
+ VAR := VAL;
+ END SET;
+ END COUNTER;
+
+ PACKAGE BODY EVENTS IS
+ PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS
+ BEGIN
+ VAR.LENGTH := VAR.LENGTH + 1;
+ VAR.TRACE(VAR.LENGTH) := VAL;
+ END UPDATE;
+
+ PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS
+ BEGIN
+ VAR := VAL;
+ END SET;
+
+ END EVENTS;
+
+ USE EVENTS, COUNTER;
+
+ PACKAGE TRACE IS NEW SHARED (EVENT_TYPE, CHARACTER, ("....", 0));
+ PACKAGE TERMINATE_COUNT IS NEW SHARED (INTEGER, INTEGER, 0);
+
+ FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS
+ BEGIN
+ TERMINATE_COUNT.UPDATE (1);
+ RETURN TRUE;
+ END ENTER_TERMINATE;
+
+BEGIN -- C94008C
+
+ TEST ("C94008C", "CHECK CORRECT OPERATION OF SELECT WITH " &
+ "TERMINATE ALTERNATIVE");
+
+ DECLARE
+
+ PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE;
+
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK BODY T1 IS
+
+ TASK T2 IS
+ ENTRY E2;
+ END T2;
+
+ TASK BODY T2 IS
+
+ TASK T3 IS
+ ENTRY E3;
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN
+ SELECT
+ ACCEPT E3;
+ OR WHEN ENTER_TERMINATE => TERMINATE;
+ END SELECT;
+ EVENT ('D');
+ END T3;
+
+ BEGIN -- T2
+
+ SELECT
+ ACCEPT E2;
+ OR WHEN ENTER_TERMINATE => TERMINATE;
+ END SELECT;
+
+ DELAY 10.0 * Impdef.One_Second;
+
+ IF TERMINATE_COUNT.GET /= 1 THEN
+ DELAY 20.0 * Impdef.One_Long_Second;
+ END IF;
+
+ IF TERMINATE_COUNT.GET /= 1 THEN
+ FAILED ("30 SECOND DELAY NOT ENOUGH - 1 ");
+ END IF;
+
+ EVENT ('C');
+ T1.E1;
+ T3.E3;
+ END T2;
+
+ BEGIN -- T1;
+
+ SELECT
+ ACCEPT E1;
+ OR WHEN ENTER_TERMINATE => TERMINATE;
+ END SELECT;
+
+ EVENT ('B');
+ TERMINATE_COUNT.SET (0);
+ T2.E2;
+
+ SELECT
+ ACCEPT E1;
+ OR WHEN ENTER_TERMINATE => TERMINATE;
+ END SELECT;
+
+ SELECT
+ ACCEPT E1;
+ OR TERMINATE; -- ONLY THIS ONE EVER CHOSEN.
+ END SELECT;
+
+ FAILED ("TERMINATE NOT SELECTED IN T1");
+ END T1;
+
+ BEGIN
+
+ DELAY 10.0 * Impdef.One_Second; -- WAIT FOR T1, T2, AND T3 TO GET TO SELECT STMTS.
+
+ IF TERMINATE_COUNT.GET /= 3 THEN
+ DELAY 20.0 * Impdef.One_Long_Second;
+ END IF;
+
+ IF TERMINATE_COUNT.GET /= 3 THEN
+ FAILED ("30 SECOND DELAY NOT ENOUGH - 2");
+ END IF;
+
+ EVENT ('A');
+ T1.E1;
+
+ EXCEPTION
+ WHEN OTHERS => FAILED ("EXCEPTION IN MAIN BLOCK");
+ END;
+
+ IF TRACE.GET.TRACE /= "ABCD" THEN
+ FAILED ("INCORRECT ORDER OF EVENTS: " & TRACE.GET.TRACE);
+ END IF;
+
+ RESULT;
+END C94008C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008d.ada b/gcc/testsuite/ada/acats/tests/c9/c94008d.ada
new file mode 100644
index 000000000..15ca61618
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94008d.ada
@@ -0,0 +1,235 @@
+-- C94008D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK CORRECT OPERATION OF SELECT WITH TERMINATE ALTERNATIVE WHEN
+-- EXECUTED FROM AN INNER BLOCK WITH OUTER DEPENDING TASKS.
+
+-- JEAN-PIERRE ROSEN 03-MAR-84
+-- JRK 4/7/86
+-- JBG 9/4/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT/SUBUNIT
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+-- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES
+GENERIC
+ TYPE HOLDER_TYPE IS PRIVATE;
+ TYPE VALUE_TYPE IS PRIVATE;
+ INITIAL_VALUE : HOLDER_TYPE;
+ WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE;
+ VALUE : IN HOLDER_TYPE) IS <>;
+ WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE;
+ VALUE : IN VALUE_TYPE) IS <>;
+PACKAGE SHARED_C94008D IS
+ PROCEDURE SET (VALUE : IN HOLDER_TYPE);
+ PROCEDURE UPDATE (VALUE : IN VALUE_TYPE);
+ FUNCTION GET RETURN HOLDER_TYPE;
+END SHARED_C94008D;
+
+PACKAGE BODY SHARED_C94008D IS
+ TASK SHARE IS
+ ENTRY SET (VALUE : IN HOLDER_TYPE);
+ ENTRY UPDATE (VALUE : IN VALUE_TYPE);
+ ENTRY READ (VALUE : OUT HOLDER_TYPE);
+ END SHARE;
+
+ TASK BODY SHARE IS SEPARATE;
+
+ PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS
+ BEGIN
+ SHARE.SET (VALUE);
+ END SET;
+
+ PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS
+ BEGIN
+ SHARE.UPDATE (VALUE);
+ END UPDATE;
+
+ FUNCTION GET RETURN HOLDER_TYPE IS
+ VALUE : HOLDER_TYPE;
+ BEGIN
+ SHARE.READ (VALUE);
+ RETURN VALUE;
+ END GET;
+
+BEGIN
+ SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE
+END SHARED_C94008D;
+
+PACKAGE EVENTS_C94008D IS
+
+ TYPE EVENT_TYPE IS
+ RECORD
+ TRACE : STRING (1..4) := "....";
+ LENGTH : NATURAL := 0;
+ END RECORD;
+
+ PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER);
+ PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE);
+END EVENTS_C94008D;
+
+PACKAGE COUNTER_C94008D IS
+ PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER);
+ PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER);
+END COUNTER_C94008D;
+
+PACKAGE BODY COUNTER_C94008D IS
+ PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS
+ BEGIN
+ VAR := VAR + VAL;
+ END UPDATE;
+
+ PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS
+ BEGIN
+ VAR := VAL;
+ END SET;
+END COUNTER_C94008D;
+
+PACKAGE BODY EVENTS_C94008D IS
+ PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS
+ BEGIN
+ VAR.LENGTH := VAR.LENGTH + 1;
+ VAR.TRACE(VAR.LENGTH) := VAL;
+ END UPDATE;
+
+ PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS
+ BEGIN
+ VAR := VAL;
+ END SET;
+
+END EVENTS_C94008D;
+
+SEPARATE (SHARED_C94008D)
+TASK BODY SHARE IS
+ VARIABLE : HOLDER_TYPE;
+BEGIN
+ LOOP
+ SELECT
+ ACCEPT SET (VALUE : IN HOLDER_TYPE) DO
+ SHARED_C94008D.SET (VARIABLE, VALUE);
+ END SET;
+ OR
+ ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO
+ SHARED_C94008D.UPDATE (VARIABLE, VALUE);
+ END UPDATE;
+ OR
+ ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO
+ VALUE := VARIABLE;
+ END READ;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+END SHARE;
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+WITH SHARED_C94008D, COUNTER_C94008D, EVENTS_C94008D;
+USE COUNTER_C94008D, EVENTS_C94008D;
+PROCEDURE C94008D IS
+
+ PACKAGE TRACE IS
+ NEW SHARED_C94008D (EVENT_TYPE, CHARACTER, ("....", 0));
+ PACKAGE TERMINATE_COUNT IS
+ NEW SHARED_C94008D (INTEGER, INTEGER, 0);
+
+ PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE;
+
+ FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS
+ BEGIN
+ TERMINATE_COUNT.UPDATE (1);
+ RETURN TRUE;
+ END ENTER_TERMINATE;
+
+BEGIN
+ TEST ("C94008D", "CHECK CORRECT OPERATION OF SELECT WITH " &
+ "TERMINATE ALTERNATIVE FROM AN INNER BLOCK");
+
+ DECLARE
+
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ DECLARE
+
+ TASK T2 IS
+ ENTRY E2;
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ DELAY 10.0 * Impdef.One_Second;
+
+ IF TERMINATE_COUNT.GET /= 1 THEN
+ DELAY 20.0 * Impdef.One_Second;
+ END IF;
+
+ IF TERMINATE_COUNT.GET /= 1 THEN
+ FAILED ("30 SECOND DELAY NOT ENOUGH");
+ END IF;
+
+ IF T1'TERMINATED OR NOT T1'CALLABLE THEN
+ FAILED ("T1 PREMATURELY TERMINATED");
+ END IF;
+
+ EVENT ('A');
+
+ SELECT
+ ACCEPT E2;
+ OR TERMINATE;
+ END SELECT;
+
+ FAILED ("TERMINATE NOT SELECTED IN T2");
+ END T2;
+
+ BEGIN
+ BEGIN
+ EVENT ('B');
+
+ SELECT
+ ACCEPT E1;
+ OR WHEN ENTER_TERMINATE => TERMINATE;
+ END SELECT;
+
+ FAILED ("TERMINATE NOT SELECTED IN T1");
+ END;
+ END;
+ END T1;
+
+ BEGIN
+ EVENT ('C');
+ EXCEPTION
+ WHEN OTHERS => FAILED ("EXCEPTION RECEIVED IN MAIN");
+ END;
+
+ IF TRACE.GET.TRACE(3) = '.' OR TRACE.GET.TRACE(4) /= '.' THEN
+ FAILED ("ALL EVENTS NOT PROCESSED CORRECTLY");
+ END IF;
+
+ COMMENT ("EXECUTION ORDER WAS " & TRACE.GET.TRACE);
+
+ RESULT;
+END C94008D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94010a.ada b/gcc/testsuite/ada/acats/tests/c9/c94010a.ada
new file mode 100644
index 000000000..3fe4bd6f2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94010a.ada
@@ -0,0 +1,243 @@
+-- C94010A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF A GENERIC UNIT HAS A FORMAL LIMITED PRIVATE TYPE AND
+-- DECLARES AN OBJECT OF THAT TYPE (OR HAS A SUBCOMPONENT OF THAT TYPE),
+-- AND IF THE UNIT IS INSTANTIATED WITH A TASK TYPE OR AN OBJECT HAVING
+-- A SUBCOMPONENT OF A TASK TYPE, THEN THE USUAL RULES APPLY TO THE
+-- INSTANTIATED UNIT, NAMELY:
+-- A) IF THE GENERIC UNIT IS A SUBPROGRAM, CONTROL CANNOT LEAVE THE
+-- SUBPROGRAM UNTIL THE TASK CREATED BY THE OBJECT DECLARATION IS
+-- TERMINATED.
+
+-- THIS TEST CONTAINS RACE CONDITIONS AND SHARED VARIABLES.
+
+-- TBN 9/22/86
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C94010A IS
+
+ GLOBAL_INT : INTEGER := 0;
+ MY_EXCEPTION : EXCEPTION;
+
+ PACKAGE P IS
+ TYPE LIM_PRI_TASK IS LIMITED PRIVATE;
+ PRIVATE
+ TASK TYPE LIM_PRI_TASK IS
+ END LIM_PRI_TASK;
+ END P;
+
+ USE P;
+
+ TASK TYPE TT IS
+ END TT;
+
+ TYPE REC IS
+ RECORD
+ A : INTEGER := 1;
+ B : TT;
+ END RECORD;
+
+ TYPE LIM_REC IS
+ RECORD
+ A : INTEGER := 1;
+ B : LIM_PRI_TASK;
+ END RECORD;
+
+ PACKAGE BODY P IS
+ TASK BODY LIM_PRI_TASK IS
+ BEGIN
+ DELAY 30.0 * Impdef.One_Second;
+ GLOBAL_INT := IDENT_INT (2);
+ END LIM_PRI_TASK;
+ END P;
+
+ TASK BODY TT IS
+ BEGIN
+ DELAY 30.0 * Impdef.One_Second;
+ GLOBAL_INT := IDENT_INT (1);
+ END TT;
+
+ GENERIC
+ TYPE T IS LIMITED PRIVATE;
+ PROCEDURE PROC (A : INTEGER);
+
+ PROCEDURE PROC (A : INTEGER) IS
+ OBJ_T : T;
+ BEGIN
+ IF A = IDENT_INT (1) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ END PROC;
+
+ GENERIC
+ TYPE T IS LIMITED PRIVATE;
+ FUNCTION FUNC (A : INTEGER) RETURN INTEGER;
+
+ FUNCTION FUNC (A : INTEGER) RETURN INTEGER IS
+ OBJ_T : T;
+ BEGIN
+ IF A = IDENT_INT (1) THEN
+ RAISE MY_EXCEPTION;
+ END IF;
+ RETURN 1;
+ END FUNC;
+
+
+BEGIN
+ TEST ("C94010A", "CHECK TERMINATION RULES FOR INSTANTIATIONS OF " &
+ "GENERIC SUBPROGRAM UNITS WHICH CREATE TASKS");
+
+ -------------------------------------------------------------------
+ DECLARE
+ PROCEDURE PROC1 IS NEW PROC (TT);
+ BEGIN
+ PROC1 (0);
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 1");
+ DELAY 35.0;
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ PROCEDURE PROC2 IS NEW PROC (REC);
+ BEGIN
+ PROC2 (1);
+ FAILED ("EXCEPTION WAS NOT RAISED - 2");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 2");
+ DELAY 35.0 * Impdef.One_Second;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ PROCEDURE PROC3 IS NEW PROC (LIM_PRI_TASK);
+ BEGIN
+ PROC3 (1);
+ FAILED ("EXCEPTION WAS NOT RAISED - 3");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 3");
+ DELAY 35.0 * Impdef.One_Second;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ PROCEDURE PROC4 IS NEW PROC (LIM_REC);
+ BEGIN
+ PROC4 (0);
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 4");
+ DELAY 35.0 * Impdef.One_Second;
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ A : INTEGER;
+ FUNCTION FUNC1 IS NEW FUNC (TT);
+ BEGIN
+ A := FUNC1 (1);
+ FAILED ("EXCEPTION NOT RAISED - 5");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 5");
+ DELAY 35.0 * Impdef.One_Second;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ A : INTEGER;
+ FUNCTION FUNC2 IS NEW FUNC (REC);
+ BEGIN
+ A := FUNC2 (0);
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 6");
+ DELAY 35.0 * Impdef.One_Second;
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ A : INTEGER;
+ FUNCTION FUNC3 IS NEW FUNC (LIM_PRI_TASK);
+ BEGIN
+ A := FUNC3 (0);
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 7");
+ DELAY 35.0 * Impdef.One_Second;
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ A : INTEGER;
+ FUNCTION FUNC4 IS NEW FUNC (LIM_REC);
+ BEGIN
+ A := FUNC4 (1);
+ FAILED ("EXCEPTION NOT RAISED - 8");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 8");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 8");
+ END;
+
+ -------------------------------------------------------------------
+
+ RESULT;
+END C94010A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94011a.ada b/gcc/testsuite/ada/acats/tests/c9/c94011a.ada
new file mode 100644
index 000000000..c504f0692
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94011a.ada
@@ -0,0 +1,268 @@
+-- C94011A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF A FORMAL ACCESS TYPE OF A GENERIC UNIT DESIGNATES A
+-- FORMAL LIMITED PRIVATE TYPE, THEN WHEN THE UNIT IS INSTANTIATED WITH
+-- A TASK TYPE OR A TYPE HAVING A SUBCOMPONENT OF A TASK TYPE, THE
+-- MASTER FOR ANY TASKS ALLOCATED WITHIN THE INSTANTIATED UNIT IS
+-- DETERMINED BY THE ACTUAL PARAMETER.
+
+-- TBN 9/22/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C94011A IS
+
+ GLOBAL_INT : INTEGER := 0;
+ MY_EXCEPTION : EXCEPTION;
+
+ PACKAGE P IS
+ TYPE LIM_PRI_TASK IS LIMITED PRIVATE;
+ PROCEDURE E (T : LIM_PRI_TASK);
+ PRIVATE
+ TASK TYPE LIM_PRI_TASK IS
+ ENTRY E;
+ END LIM_PRI_TASK;
+ END P;
+
+ USE P;
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ TYPE REC IS
+ RECORD
+ A : INTEGER := 1;
+ B : TT;
+ END RECORD;
+
+ TYPE LIM_REC IS
+ RECORD
+ A : INTEGER := 1;
+ B : LIM_PRI_TASK;
+ END RECORD;
+
+ PACKAGE BODY P IS
+ TASK BODY LIM_PRI_TASK IS
+ BEGIN
+ ACCEPT E;
+ GLOBAL_INT := IDENT_INT (2);
+ END LIM_PRI_TASK;
+
+ PROCEDURE E (T : LIM_PRI_TASK) IS
+ BEGIN
+ T.E;
+ END E;
+ END P;
+
+ TASK BODY TT IS
+ BEGIN
+ ACCEPT E;
+ GLOBAL_INT := IDENT_INT (1);
+ END TT;
+
+ GENERIC
+ TYPE T IS LIMITED PRIVATE;
+ TYPE ACC_T IS ACCESS T;
+ PROCEDURE PROC (A : OUT ACC_T);
+
+ PROCEDURE PROC (A : OUT ACC_T) IS
+ BEGIN
+ A := NEW T;
+ END PROC;
+
+ GENERIC
+ TYPE T IS LIMITED PRIVATE;
+ TYPE ACC_T IS ACCESS T;
+ FUNCTION FUNC RETURN ACC_T;
+
+ FUNCTION FUNC RETURN ACC_T IS
+ BEGIN
+ RETURN NEW T;
+ END FUNC;
+
+ GENERIC
+ TYPE T IS LIMITED PRIVATE;
+ TYPE ACC_T IS ACCESS T;
+ PACKAGE PAC IS
+ PTR_T : ACC_T := NEW T;
+ END PAC;
+
+BEGIN
+ TEST ("C94011A", "CHECK THAT IF A FORMAL ACCESS TYPE OF A " &
+ "GENERIC UNIT DESIGNATES A FORMAL LIMITED " &
+ "PRIVATE TYPE, THEN WHEN THE UNIT IS " &
+ "INSTANTIATED, THE MASTER FOR ANY TASKS " &
+ "ALLOCATED WITHIN THE INSTANTIATED UNIT IS " &
+ "DETERMINED BY THE ACTUAL PARAMETER");
+
+ -------------------------------------------------------------------
+ DECLARE
+ TYPE ACC_TT IS ACCESS TT;
+ ACC1 : ACC_TT;
+ PROCEDURE PROC1 IS NEW PROC (TT, ACC_TT);
+ BEGIN
+ PROC1 (ACC1);
+ ACC1.E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("TASK DEPENDENT ON WRONG MASTER - 1");
+ END;
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 1");
+ END IF;
+
+ -------------------------------------------------------------------
+ BEGIN
+ GLOBAL_INT := IDENT_INT (0);
+ DECLARE
+ TYPE ACC_REC IS ACCESS REC;
+ A : ACC_REC;
+ FUNCTION FUNC1 IS NEW FUNC (REC, ACC_REC);
+ BEGIN
+ A := FUNC1;
+ A.B.E;
+ RAISE MY_EXCEPTION;
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ RAISE MY_EXCEPTION;
+ WHEN OTHERS =>
+ FAILED ("TASK DEPENDENT ON WRONG MASTER - 2");
+ END;
+ FAILED ("MY_EXCEPTION NOT RAISED - 2");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 2");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ BEGIN
+ DECLARE
+ TYPE ACC_LIM_TT IS ACCESS LIM_PRI_TASK;
+ BEGIN
+ DECLARE
+ A : ACC_LIM_TT;
+ FUNCTION FUNC2 IS NEW FUNC (LIM_PRI_TASK,
+ ACC_LIM_TT);
+ BEGIN
+ A := FUNC2;
+ E (A.ALL);
+ END;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("TASK DEPENDENT ON WRONG MASTER - 3");
+ END;
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 3");
+ END IF;
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ BEGIN
+ DECLARE
+ TYPE ACC_LIM_REC IS ACCESS LIM_REC;
+ BEGIN
+ DECLARE
+ ACC2 : ACC_LIM_REC;
+ PROCEDURE PROC2 IS NEW PROC (LIM_REC, ACC_LIM_REC);
+ BEGIN
+ PROC2 (ACC2);
+ E (ACC2.B);
+ END;
+ RAISE MY_EXCEPTION;
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ RAISE MY_EXCEPTION;
+ WHEN OTHERS =>
+ FAILED ("TASK DEPENDENT ON WRONG MASTER - 4");
+ END;
+ FAILED ("MY_EXCEPTION NOT RAISED - 4");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 4");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
+ END;
+
+ -------------------------------------------------------------------
+ BEGIN
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ TYPE ACC_TT IS ACCESS TT;
+ PACKAGE PAC1 IS NEW PAC (TT, ACC_TT);
+ USE PAC1;
+ BEGIN
+ PTR_T.E;
+ RAISE MY_EXCEPTION;
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ RAISE MY_EXCEPTION;
+ WHEN OTHERS =>
+ FAILED ("TASK DEPENDENT ON WRONG MASTER - 5");
+ END;
+ FAILED ("MY_EXCEPTION NOT RAISED - 5");
+ EXCEPTION
+ WHEN MY_EXCEPTION =>
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 5");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
+ END;
+
+ -------------------------------------------------------------------
+ GLOBAL_INT := IDENT_INT (0);
+
+ DECLARE
+ TYPE ACC_LIM_REC IS ACCESS LIM_REC;
+ BEGIN
+ DECLARE
+ PACKAGE PAC2 IS NEW PAC (LIM_REC, ACC_LIM_REC);
+ USE PAC2;
+ BEGIN
+ E (PTR_T.B);
+ END;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("TASK DEPENDENT ON WRONG MASTER - 6");
+ END;
+ IF GLOBAL_INT = IDENT_INT (0) THEN
+ FAILED ("TASK NOT DEPENDENT ON MASTER - 6");
+ END IF;
+
+ -------------------------------------------------------------------
+
+ RESULT;
+END C94011A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c94020a.ada b/gcc/testsuite/ada/acats/tests/c9/c94020a.ada
new file mode 100644
index 000000000..4a5037ecd
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c94020a.ada
@@ -0,0 +1,111 @@
+-- C94020A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE CONDITIONS FOR TERMINATION ARE RECOGNIZED WHEN THE
+-- LAST MISSING TASK TERMINATES DUE TO AN ABORT
+
+-- JEAN-PIERRE ROSEN 08-MAR-1984
+-- JBG 6/1/84
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C94020A IS
+
+ TASK TYPE T2 IS
+ END T2;
+
+ TASK TYPE T3 IS
+ ENTRY E;
+ END T3;
+
+ TASK BODY T2 IS
+ BEGIN
+ COMMENT("T2");
+ END;
+
+ TASK BODY T3 IS
+ BEGIN
+ COMMENT("T3");
+ SELECT
+ ACCEPT E;
+ OR TERMINATE;
+ END SELECT;
+ FAILED("T3 EXITED SELECT OR TERMINATE");
+ END;
+
+BEGIN
+
+ TEST ("C94020A", "TEST OF TASK DEPENDENCES, TERMINATE, ABORT");
+
+ DECLARE
+ TASK TYPE T1 IS
+ END T1;
+
+ V1 : T1;
+ TYPE A_T1 IS ACCESS T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ABORT T1;
+ DELAY 0.0; --SYNCHRONIZATION POINT
+ FAILED("T1 NOT ABORTED");
+ END;
+
+ BEGIN
+ DECLARE
+ V2 : T2;
+ A1 : A_T1;
+ BEGIN
+ DECLARE
+ V3 : T3;
+ TASK T4 IS
+ END T4;
+ TASK BODY T4 IS
+ TASK T41 IS
+ END T41;
+ TASK BODY T41 IS
+ BEGIN
+ COMMENT("T41");
+ ABORT T4;
+ DELAY 0.0; --SYNCHRONIZATION POINT
+ FAILED("T41 NOT ABORTED");
+ END;
+ BEGIN --T4
+ COMMENT("T4");
+ END;
+ BEGIN
+ COMMENT("BLOC 3");
+ END;
+ COMMENT("BLOC 2");
+ A1 := NEW T1;
+ END;
+ COMMENT("BLOC 1");
+ EXCEPTION
+ WHEN OTHERS => FAILED("SOME EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+END C94020A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940a03.a b/gcc/testsuite/ada/acats/tests/c9/c940a03.a
new file mode 100644
index 000000000..22876d26b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c940a03.a
@@ -0,0 +1,350 @@
+-- C940A03.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a protected object provides coordinated access to
+-- shared data. Check that it can implement a semaphore-like construct
+-- controlling access to shared data through procedure parameters to
+-- allow a specific maximum number of tasks to run and exclude all
+-- others.
+--
+-- TEST DESCRIPTION:
+-- Declare a resource descriptor tagged type. Extend the type and
+-- use the extended type in a protected data structure.
+-- Implement a counting semaphore type that can be initialized to a
+-- specific number of available resources. Declare an entry for
+-- requesting a specific resource and an procedure for releasing the
+-- same resource it. Declare an object of this (protected) type,
+-- initialized to two resources. Declare and start three tasks each
+-- of which asks for a resource. Verify that only two resources are
+-- granted and that the last task in is queued.
+--
+-- This test models a multi-user operating system that allows a limited
+-- number of logins. Users requesting login are modeled by tasks.
+--
+--
+-- TEST FILES:
+-- This test depends on the following foundation code:
+--
+-- F940A00
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 13 Nov 95 SAIC Fixed bugs for ACVC 2.0.1
+--
+--!
+
+package C940A03_0 is
+ --Resource_Pkg
+
+ -- General type declarations that will be extended to model available
+ -- logins
+
+ type Resource_ID_Type is range 0..10;
+ type Resource_Type is tagged record
+ Id : Resource_ID_Type := 0;
+ end record;
+
+end C940A03_0;
+ --Resource_Pkg
+
+--======================================--
+-- no body for C940A3_0
+--======================================--
+
+with F940A00; -- Interlock_Foundation
+with C940A03_0; -- Resource_Pkg;
+
+package C940A03_1 is
+ -- Semaphores
+
+ -- Models a counting semaphore that will allow up to a specific
+ -- number of logins
+ -- Users (tasks) request a login slot by calling the Request_Login
+ -- entry and logout by calling the Release_Login procedure
+
+ Max_Logins : constant Integer := 2;
+
+
+ type Key_Type is range 0..100;
+ -- When a user requests a login, an
+ -- identifying key will be returned
+ Init_Key : constant Key_Type := 0;
+
+ type Login_Record_Type is new C940A03_0.Resource_Type with record
+ Key : Key_Type := Init_Key;
+ end record;
+
+
+ protected type Login_Semaphore_Type (Resources_Available : Integer :=1) is
+
+ entry Request_Login (Resource_Key : in out Login_Record_Type);
+ procedure Release_Login;
+ function Available return Integer; -- how many logins are available?
+ private
+ Logins_Avail : Integer := Resources_Available;
+ Next_Key : Key_Type := Init_Key;
+
+ end Login_Semaphore_Type;
+
+ Login_Semaphore : Login_Semaphore_Type (Max_Logins);
+
+ --====== machinery for the test, not the model =====--
+ TC_Control_Message : F940A00.Interlock_Type;
+ function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer;
+
+
+end C940A03_1;
+ -- Semaphores;
+
+--=========================================================--
+
+package body C940A03_1 is
+ -- Semaphores is
+
+ protected body Login_Semaphore_Type is
+
+ entry Request_Login (Resource_Key : in out Login_Record_Type)
+ when Logins_Avail > 0 is
+ begin
+ Next_Key := Next_Key + 1; -- login process returns a key
+ Resource_Key.Key := Next_Key; -- to the requesting user
+ Logins_Avail := Logins_Avail - 1;
+ end Request_Login;
+
+ procedure Release_Login is
+ begin
+ Logins_Avail := Logins_Avail + 1;
+ end Release_Login;
+
+ function Available return Integer is
+ begin
+ return Logins_Avail;
+ end Available;
+
+ end Login_Semaphore_Type;
+
+ function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer is
+ begin
+ return Integer (Login_Rec.Key);
+ end TC_Key_Val;
+
+end C940A03_1;
+ -- Semaphores;
+
+--=========================================================--
+
+with C940A03_0; -- Resource_Pkg,
+with C940A03_1; -- Semaphores;
+
+package C940A03_2 is
+ -- Task_Pkg
+
+ package Semaphores renames C940A03_1;
+
+ task type User_Task_Type is
+
+ entry Login (user_id : C940A03_0.Resource_Id_Type);
+ -- instructs the task to ask for a login
+ entry Logout; -- instructs the task to release the login
+ --=======================--
+ -- this entry is used to get information to verify test operation
+ entry Get_Status (User_Record : out Semaphores.Login_Record_Type);
+
+ end User_Task_Type;
+
+end C940A03_2;
+ -- Task_Pkg
+
+--=========================================================--
+
+with Report;
+with C940A03_0; -- Resource_Pkg,
+with C940A03_1; -- Semaphores,
+with F940A00; -- Interlock_Foundation;
+
+package body C940A03_2 is
+ -- Task_Pkg
+
+ -- This task models a user requesting a login from the system
+ -- For control of this test, we can ask the task to login, logout, or
+ -- give us the current user record (containing login information)
+
+ task body User_Task_Type is
+ Rec : Semaphores.Login_Record_Type;
+ begin
+ loop
+ select
+ accept Login (user_id : C940A03_0.Resource_Id_Type) do
+ Rec.Id := user_id;
+ end Login;
+
+ Semaphores.Login_Semaphore.Request_Login (Rec);
+ -- request a resource; if resource is not available,
+ -- task will be queued to wait
+
+ --== following is test control machinery ==--
+ F940A00.Counter.Increment;
+ Semaphores.TC_Control_Message.Post;
+ -- after resource is obtained, post message
+
+ or
+ accept Logout do
+ Semaphores.Login_Semaphore.Release_Login;
+ -- release the resource
+ --== test control machinery ==--
+ F940A00.Counter.Decrement;
+ end Logout;
+ exit;
+
+ or
+ accept Get_Status (User_Record : out Semaphores.Login_Record_Type) do
+ User_Record := Rec;
+ end Get_Status;
+
+ end select;
+ end loop;
+
+ exception
+ when others => Report.Failed ("Exception raised in model user task");
+ end User_Task_Type;
+
+end C940A03_2;
+ -- Task_Pkg
+
+--=========================================================--
+
+with Report;
+with ImpDef;
+with C940A03_1; -- Semaphores,
+with C940A03_2; -- Task_Pkg,
+with F940A00; -- Interlock_Foundation;
+
+procedure C940A03 is
+
+ package Semaphores renames C940A03_1;
+ package Users renames C940A03_2;
+
+ Task1, Task2, Task3 : Users.User_Task_Type;
+ User_Rec : Semaphores.Login_Record_Type;
+
+begin -- Tasks start here
+
+ Report.Test ("C940A03", "Check that a protected object can coordinate " &
+ "shared data access using procedure parameters");
+
+ if F940A00.Counter.Number /=0 then
+ Report.Failed ("Wrong initial conditions");
+ end if;
+
+ Task1.Login (1); -- request resource; request should be granted
+ Semaphores.TC_Control_Message.Consume;
+ -- ensure that task obtains resource by
+ -- waiting for task to post message
+
+ -- Task 1 waiting for call to Logout
+ -- Others still available
+ Task1.Get_Status (User_Rec);
+ if (F940A00.Counter.Number /= 1)
+ or (Semaphores.Login_Semaphore.Available /=1)
+ or (Semaphores.TC_Key_Val (User_Rec) /= 1) then
+ Report.Failed ("Resource not assigned to task 1");
+ end if;
+
+ Task2.Login (2); -- Request for resource should be granted
+ Semaphores.TC_Control_Message.Consume;
+ -- ensure that task obtains resource by
+ -- waiting for task to post message
+
+ Task2.Get_Status (User_Rec);
+ if (F940A00.Counter.Number /= 2)
+ or (Semaphores.Login_Semaphore.Available /=0)
+ or (Semaphores.TC_Key_Val (User_Rec) /= 2) then
+ Report.Failed ("Resource not assigned to task 2");
+ end if;
+
+
+ Task3.Login (3); -- request for resource should be denied
+ -- and task queued
+
+
+ -- Tasks 1 and 2 holds resources
+ -- and are waiting for a call to Logout
+ -- Task 3 is queued
+
+ if (F940A00.Counter.Number /= 2)
+ or (Semaphores.Login_Semaphore.Available /=0) then
+ Report.Failed ("Resource incorrectly assigned to task 3");
+ end if;
+
+ Task1.Logout; -- released resource should be given to
+ -- queued task
+ Semaphores.TC_Control_Message.Consume;
+ -- wait for confirming message from task
+
+ -- Task 1 holds no resources
+ -- and is terminated (or will soon)
+ -- Tasks 2 and 3 hold resources
+ -- and are waiting for a call to Logout
+
+ Task3.Get_Status (User_Rec);
+ if (F940A00.Counter.Number /= 2)
+ or (Semaphores.Login_Semaphore.Available /=0)
+ or (Semaphores.TC_Key_Val (User_Rec) /= 3) then
+ Report.Failed ("Resource not properly released/assigned to task 3");
+ end if;
+
+ Task2.Logout; -- no outstanding request for released
+ -- resource
+ -- Tasks 1 and 2 hold no resources
+ -- Task 3 holds a resource
+ -- and is waiting for a call to Logout
+
+ if (F940A00.Counter.Number /= 1)
+ or (Semaphores.Login_Semaphore.Available /=1) then
+ Report.Failed ("Resource not properly released from task 2");
+ end if;
+
+ Task3.Logout;
+
+ -- all resources have been returned
+ -- all tasks have terminated or will soon
+
+ if (F940A00.Counter.Number /=0)
+ or (Semaphores.Login_Semaphore.Available /=2) then
+ Report.Failed ("Resource not properly released from task 3");
+ end if;
+
+ -- Ensure all tasks have terminated before calling Result
+ while not (Task1'terminated and
+ Task2'terminated and
+ Task3'terminated) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C940A03;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95008a.ada b/gcc/testsuite/ada/acats/tests/c9/c95008a.ada
new file mode 100644
index 000000000..4343e651b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95008a.ada
@@ -0,0 +1,426 @@
+-- C95008A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE EXCEPTION CONSTRAINT_ERROR IS RAISED FOR AN
+-- OUT-OF-RANGE INDEX VALUE WHEN REFERENCING AN ENTRY FAMILY,
+-- EITHER IN AN ACCEPT_STATEMENT OR IN AN ENTRY_CALL.
+
+-- SUBTESTS ARE:
+-- (A) INTEGER TYPE, STATIC LOWER BOUND, NO PARAMETERS.
+-- (B) CHARACTER TYPE, DYNAMIC UPPER BOUND, NO PARAMETERS.
+-- (C) BOOLEAN TYPE, STATIC NULL RANGE, NO PARAMETERS.
+-- (D) USER-DEFINED ENUMERATED TYPE, DYNAMIC LOWER BOUND, ONE
+-- PARAMETER.
+-- (E) DERIVED INTEGER TYPE, DYNAMIC NULL RANGE, ONE PARAMETER.
+-- (F) DERIVED USER-DEFINED ENUMERATED TYPE, STATIC UPPER BOUND,
+-- ONE PARAMETER.
+
+-- JRK 11/4/81
+-- JBG 11/11/84
+-- SAIC 11/14/95 fixed test for 2.0.1
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C95008A IS
+
+ C_E_NOT_RAISED : BOOLEAN;
+ WRONG_EXC_RAISED : BOOLEAN;
+
+BEGIN
+ TEST ("C95008A", "OUT-OF-RANGE ENTRY FAMILY INDICES IN " &
+ "ACCEPT_STATEMENTS AND ENTRY_CALLS");
+
+ --------------------------------------------------
+
+ C_E_NOT_RAISED := FALSE;
+ WRONG_EXC_RAISED := FALSE;
+
+ DECLARE -- (A)
+
+ TASK T IS
+ ENTRY E (1..10);
+ ENTRY CONTINUE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT CONTINUE;
+ SELECT
+ ACCEPT E (0);
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ END SELECT;
+ C_E_NOT_RAISED := TRUE;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ WRONG_EXC_RAISED := TRUE;
+ END T;
+
+ BEGIN -- (A)
+
+ SELECT
+ T.E (0);
+ OR
+ DELAY 15.0 * Impdef.One_Second;
+ END SELECT;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ENTRY_CALL - (A)");
+ T.CONTINUE;
+
+ EXCEPTION -- (A)
+
+ WHEN CONSTRAINT_ERROR =>
+ T.CONTINUE;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ENTRY_CALL - (A)");
+ T.CONTINUE;
+
+ END; -- (A)
+
+ IF C_E_NOT_RAISED THEN
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ACCEPT_STATEMENT - (A)");
+ END IF;
+
+ IF WRONG_EXC_RAISED THEN
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ACCEPT_STATEMENT - (A)");
+ END IF;
+
+ --------------------------------------------------
+
+ C_E_NOT_RAISED := FALSE;
+ WRONG_EXC_RAISED := FALSE;
+
+ DECLARE -- (B)
+
+ TASK T IS
+ ENTRY E (CHARACTER RANGE 'A'..'Y');
+ ENTRY CONTINUE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT CONTINUE;
+ SELECT
+ ACCEPT E (IDENT_CHAR('Z'));
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ END SELECT;
+ C_E_NOT_RAISED := TRUE;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ WRONG_EXC_RAISED := TRUE;
+ END T;
+
+ BEGIN -- (B)
+
+ SELECT
+ T.E (IDENT_CHAR('Z'));
+ OR
+ DELAY 15.0 * Impdef.One_Second;
+ END SELECT;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ENTRY_CALL - (B)");
+ T.CONTINUE;
+
+ EXCEPTION -- (B)
+
+ WHEN CONSTRAINT_ERROR =>
+ T.CONTINUE;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ENTRY_CALL - (B)");
+ T.CONTINUE;
+
+ END; -- (B)
+
+ IF C_E_NOT_RAISED THEN
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ACCEPT_STATEMENT - (B)");
+ END IF;
+
+ IF WRONG_EXC_RAISED THEN
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ACCEPT_STATEMENT - (B)");
+ END IF;
+
+ --------------------------------------------------
+
+ C_E_NOT_RAISED := FALSE;
+ WRONG_EXC_RAISED := FALSE;
+
+ DECLARE -- (C)
+
+ TASK T IS
+ ENTRY E (TRUE..FALSE);
+ ENTRY CONTINUE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT CONTINUE;
+ SELECT
+ ACCEPT E (FALSE);
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ END SELECT;
+ C_E_NOT_RAISED := TRUE;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ WRONG_EXC_RAISED := TRUE;
+ END T;
+
+ BEGIN -- (C)
+
+ SELECT
+ T.E (TRUE);
+ OR
+ DELAY 15.0 * Impdef.One_Second;
+ END SELECT;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ENTRY_CALL - (C)");
+ T.CONTINUE;
+
+ EXCEPTION -- (C)
+
+ WHEN CONSTRAINT_ERROR =>
+ T.CONTINUE;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ENTRY_CALL - (C)");
+ T.CONTINUE;
+
+ END; -- (C)
+
+ IF C_E_NOT_RAISED THEN
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ACCEPT_STATEMENT - (C)");
+ END IF;
+
+ IF WRONG_EXC_RAISED THEN
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ACCEPT_STATEMENT - (C)");
+ END IF;
+
+ --------------------------------------------------
+
+ C_E_NOT_RAISED := FALSE;
+ WRONG_EXC_RAISED := FALSE;
+
+ DECLARE -- (D)
+
+ TYPE ET IS (E0, E1, E2);
+ DLB : ET := ET'VAL (IDENT_INT(1)); -- E1.
+
+ TASK T IS
+ ENTRY E (ET RANGE DLB..E2) (I : INTEGER);
+ ENTRY CONTINUE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT CONTINUE;
+ SELECT
+ ACCEPT E (E0) (I : INTEGER);
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ END SELECT;
+ C_E_NOT_RAISED := TRUE;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ WRONG_EXC_RAISED := TRUE;
+ END T;
+
+ BEGIN -- (D)
+
+ SELECT
+ T.E (E0) (0);
+ OR
+ DELAY 15.0 * Impdef.One_Second;
+ END SELECT;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ENTRY_CALL - (D)");
+ T.CONTINUE;
+
+ EXCEPTION -- (D)
+
+ WHEN CONSTRAINT_ERROR =>
+ T.CONTINUE;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ENTRY_CALL - (D)");
+ T.CONTINUE;
+
+ END; -- (D)
+
+ IF C_E_NOT_RAISED THEN
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ACCEPT_STATEMENT - (D)");
+ END IF;
+
+ IF WRONG_EXC_RAISED THEN
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ACCEPT_STATEMENT - (D)");
+ END IF;
+
+ --------------------------------------------------
+
+ C_E_NOT_RAISED := FALSE;
+ WRONG_EXC_RAISED := FALSE;
+
+ DECLARE -- (E)
+
+ TYPE D_I IS NEW INTEGER;
+ SUBTYPE DI IS D_I RANGE 3 .. D_I(IDENT_INT(2));
+
+ TASK T IS
+ ENTRY E (DI) (I : INTEGER);
+ ENTRY CONTINUE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT CONTINUE;
+ SELECT
+ ACCEPT E (D_I(3)) (I : INTEGER);
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ END SELECT;
+ C_E_NOT_RAISED := TRUE;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ WRONG_EXC_RAISED := TRUE;
+ END T;
+
+ BEGIN -- (E)
+
+ SELECT
+ T.E (D_I(2)) (0);
+ OR
+ DELAY 15.0 * Impdef.One_Second;
+ END SELECT;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ENTRY_CALL - (E)");
+ T.CONTINUE;
+
+ EXCEPTION -- (E)
+
+ WHEN CONSTRAINT_ERROR =>
+ T.CONTINUE;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ENTRY_CALL - (E)");
+ T.CONTINUE;
+
+ END; -- (E)
+
+ IF C_E_NOT_RAISED THEN
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ACCEPT_STATEMENT - (E)");
+ END IF;
+
+ IF WRONG_EXC_RAISED THEN
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ACCEPT_STATEMENT - (E)");
+ END IF;
+
+ --------------------------------------------------
+
+ C_E_NOT_RAISED := FALSE;
+ WRONG_EXC_RAISED := FALSE;
+
+ DECLARE -- (F)
+
+ TYPE ET IS (E0, E1, E2);
+ TYPE D_ET IS NEW ET;
+
+ TASK T IS
+ ENTRY E (D_ET RANGE E0..E1) (I : INTEGER);
+ ENTRY CONTINUE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT CONTINUE;
+ SELECT
+ ACCEPT E (D_ET'(E2)) (I : INTEGER);
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ END SELECT;
+ C_E_NOT_RAISED := TRUE;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ WRONG_EXC_RAISED := TRUE;
+ END T;
+
+ BEGIN -- (F)
+
+ SELECT
+ T.E (D_ET'(E2)) (0);
+ OR
+ DELAY 15.0 * Impdef.One_Second;
+ END SELECT;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ENTRY_CALL - (F)");
+ T.CONTINUE;
+
+ EXCEPTION -- (F)
+
+ WHEN CONSTRAINT_ERROR =>
+ T.CONTINUE;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ENTRY_CALL - (F)");
+ T.CONTINUE;
+
+ END; -- (F)
+
+ IF C_E_NOT_RAISED THEN
+ FAILED ("CONSTRAINT_ERROR NOT RAISED IN " &
+ "ACCEPT_STATEMENT - (F)");
+ END IF;
+
+ IF WRONG_EXC_RAISED THEN
+ FAILED ("WRONG EXCEPTION RAISED IN " &
+ "ACCEPT_STATEMENT - (F)");
+ END IF;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95008A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95009a.ada b/gcc/testsuite/ada/acats/tests/c9/c95009a.ada
new file mode 100644
index 000000000..30830e96c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95009a.ada
@@ -0,0 +1,121 @@
+-- C95009A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK OBJECT CAN CALL ENTRIES OF OTHER TASKS.
+
+-- THIS TEST CONTAINS SHARED VARIABLES.
+
+-- JRK 11/5/81
+-- JRK 8/3/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95009A IS
+
+ V1 : INTEGER := 0;
+ V2 : INTEGER := 0;
+
+ PI : INTEGER := 0;
+ PO : INTEGER := 0;
+
+BEGIN
+ TEST ("C95009A", "CHECK THAT A TASK OBJECT CAN CALL ENTRIES " &
+ "OF OTHER TASKS");
+
+ DECLARE
+
+ SUBTYPE INT IS INTEGER RANGE 1..5;
+
+ TASK T1 IS
+ ENTRY E1N;
+ ENTRY EF1P (INT) (I : OUT INTEGER);
+ END T1;
+
+ TASK TYPE T2T IS
+ ENTRY E2P (I : INTEGER);
+ ENTRY EF2N (INT);
+ END T2T;
+
+ TYPE AT2T IS ACCESS T2T;
+ AT2 : AT2T;
+
+ TASK BODY T1 IS
+ BEGIN
+ V1 := 1;
+ ACCEPT E1N;
+ V1 := 2;
+ AT2.E2P (1);
+ V1 := 3;
+ ACCEPT EF1P (2) (I : OUT INTEGER) DO
+ I := 2;
+ END EF1P;
+ V1 := 4;
+ AT2.EF2N (IDENT_INT(3));
+ V1 := 5;
+ END T1;
+
+ TASK BODY T2T IS
+ BEGIN
+ V2 := 1;
+ T1.E1N;
+ V2 := 2;
+ ACCEPT E2P (I : INTEGER) DO
+ PI := I;
+ END E2P;
+ V2 := 3;
+ T1.EF1P (2) (PO);
+ V2 := 4;
+ ACCEPT EF2N (1+IDENT_INT(2));
+ V2 := 5;
+ END T2T;
+
+ PACKAGE DUMMY IS
+ END DUMMY;
+
+ PACKAGE BODY DUMMY IS
+ BEGIN
+ AT2 := NEW T2T;
+ END DUMMY;
+
+ BEGIN
+ NULL;
+ END;
+
+ IF V1 /= 5 THEN
+ FAILED ("TASK T1 ONLY REACHED V1 = " & INTEGER'IMAGE(V1));
+ END IF;
+
+ IF V2 /= 5 THEN
+ FAILED ("TASK AT2 ONLY REACHED V2 = " & INTEGER'IMAGE(V2));
+ END IF;
+
+ IF PI /= 1 THEN
+ FAILED ("ENTRY IN PARAMETER NOT PASSED CORRECTLY");
+ END IF;
+
+ IF PO /= 2 THEN
+ FAILED ("ENTRY OUT PARAMETER NOT PASSED CORRECTLY");
+ END IF;
+
+ RESULT;
+END C95009A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95010a.ada b/gcc/testsuite/ada/acats/tests/c9/c95010a.ada
new file mode 100644
index 000000000..362956058
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95010a.ada
@@ -0,0 +1,82 @@
+-- C95010A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK MAY CONTAIN MORE THAN ONE ACCEPT_STATEMENT
+-- FOR AN ENTRY.
+
+-- THIS TEST CONTAINS SHARED VARIABLES.
+
+-- JRK 11/5/81
+-- JWC 6/28/85 RENAMED TO -AB
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95010A IS
+
+ V : INTEGER := 0;
+
+BEGIN
+ TEST ("C95010A", "CHECK THAT A TASK MAY CONTAIN MORE THAN " &
+ "ONE ACCEPT_STATEMENT FOR AN ENTRY");
+
+ DECLARE
+
+ SUBTYPE INT IS INTEGER RANGE 1..5;
+
+ TASK T IS
+ ENTRY E;
+ ENTRY EF (INT) (I : INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ V := 1;
+ ACCEPT E;
+ V := 2;
+ ACCEPT E;
+ V := 3;
+ ACCEPT EF (2) (I : INTEGER) DO
+ V := I;
+ END EF;
+ V := 5;
+ ACCEPT EF (2) (I : INTEGER) DO
+ V := I;
+ END EF;
+ V := 7;
+ END T;
+
+ BEGIN
+
+ T.E;
+ T.E;
+ T.EF (2) (4);
+ T.EF (2) (6);
+
+ END;
+
+ IF V /= 7 THEN
+ FAILED ("WRONG CONTROL FLOW VALUE");
+ END IF;
+
+ RESULT;
+END C95010A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95011a.ada b/gcc/testsuite/ada/acats/tests/c9/c95011a.ada
new file mode 100644
index 000000000..1e91a847c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95011a.ada
@@ -0,0 +1,67 @@
+-- C95011A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK NEED NOT CONTAIN ANY ACCEPT_STATEMENTS FOR AN
+-- ENTRY.
+
+-- THIS TEST CONTAINS SHARED VARIABLES.
+
+-- JRK 11/5/81
+-- JWC 6/28/85 RENAMED TO -AB
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95011A IS
+
+ V : INTEGER := 0;
+
+BEGIN
+ TEST ("C95011A", "CHECK THAT A TASK NEED NOT CONTAIN ANY " &
+ "ACCEPT_STATEMENTS FOR AN ENTRY");
+
+ DECLARE
+
+ SUBTYPE INT IS INTEGER RANGE 1..5;
+
+ TASK T IS
+ ENTRY E;
+ ENTRY EF (INT) (I : INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ V := 1;
+ END T;
+
+ BEGIN
+
+ NULL;
+
+ END;
+
+ IF V /= 1 THEN
+ FAILED ("WRONG CONTROL FLOW VALUE");
+ END IF;
+
+ RESULT;
+END C95011A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95012a.ada b/gcc/testsuite/ada/acats/tests/c9/c95012a.ada
new file mode 100644
index 000000000..2f7efaacb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95012a.ada
@@ -0,0 +1,106 @@
+-- C95012A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CALL TO AN ENTRY OF A TASK THAT HAS NOT BEEN ACTIVATED
+-- DOES NOT RAISE EXCEPTIONS.
+
+-- THIS TEST CONTAINS RACE CONDITIONS.
+
+-- JRK 11/6/81
+-- SPS 11/21/82
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C95012A IS
+
+ I : INTEGER := 0;
+
+
+BEGIN
+ TEST ("C95012A", "CHECK THAT A CALL TO AN ENTRY OF A TASK " &
+ "THAT HAS NOT BEEN ACTIVATED DOES NOT " &
+ "RAISE EXCEPTIONS");
+
+ DECLARE
+
+ TASK T1 IS
+ ENTRY E1 (I : OUT INTEGER);
+ END T1;
+
+ TASK TYPE T2T IS
+ ENTRY E2 (I : OUT INTEGER);
+ END T2T;
+
+ TYPE AT2T IS ACCESS T2T;
+ AT2 : AT2T;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (I : OUT INTEGER) DO
+ I := IDENT_INT (1);
+ END E1;
+ END T1;
+
+ TASK BODY T2T IS
+ J : INTEGER := 0;
+ BEGIN
+ BEGIN
+ T1.E1 (J);
+ EXCEPTION
+ WHEN OTHERS =>
+ J := -1;
+ END;
+ ACCEPT E2 (I : OUT INTEGER) DO
+ I := J;
+ END E2;
+ END T2T;
+
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ AT2 := NEW T2T;
+ DELAY 60.0 * Impdef.One_Second;
+ END PKG;
+
+ BEGIN
+
+ AT2.ALL.E2 (I);
+
+ IF I = -1 THEN
+ FAILED ("EXCEPTION RAISED");
+ T1.E1 (I);
+ END IF;
+
+ IF I /= 1 THEN
+ FAILED ("WRONG VALUE PASSED");
+ END IF;
+
+ END;
+
+ RESULT;
+END C95012A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95021a.ada b/gcc/testsuite/ada/acats/tests/c9/c95021a.ada
new file mode 100644
index 000000000..a0c047bad
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95021a.ada
@@ -0,0 +1,182 @@
+-- C95021A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CALLS TO AN ENTRY ARE PLACED IN A FIFO QUEUE.
+
+-- JBG 2/22/84
+-- DAS 10/8/90 ADDED PRAGMA PRIORITY TO ENSURE THAT THE FIFO
+-- DISCIPLINE MUST BE FOLLOWED (OTHERWISE THE
+-- IMPLEMENTATION MIGHT PROHIBIT QUEUES FROM
+-- FORMING SO THAT E'COUNT IS ALWAYS ZERO FOR
+-- AN ENTRY E).
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+-- THE TASK QUEUE IS THE TASK THAT CHECKS THE QUEUEING DISCIPLINE.
+--
+-- THIS TEST PLACES TWO CALLS ON AN ENTRY, WAITS UNTIL ONE OF THE CALLS
+-- IS ACCEPTED, AND THEN PLACES A THIRD CALL ON THE ENTRY. THE TEST
+-- CHECKS THAT THE SECOND CALL IS HANDLED BEFORE THE THIRD. (IT IS
+-- NONDETERMINISTIC WHICH CALL WILL BE THE FIRST ONE ON THE QUEUE, SO
+-- THIS MORE COMPLICATED APPROACH IS NECESSARY.)
+--
+-- THE TASK DISPATCH FIRES UP THE TWO TASKS THAT MAKE THE FIRST TWO
+-- CALLS AND THEN WAITS UNTIL QUEUE SAYS IT IS READY FOR THE THIRD CALL.
+--
+-- THE TASK TYPE CALLERS IS USED TO CREATE TASKS THAT WILL CALL THE
+-- ENTRY IN THE TASK QUEUE.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM;
+PROCEDURE C95021A IS
+BEGIN
+
+ TEST ("C95021A", "CHECK THAT ENTRY CALLS ARE PUT IN FIFO QUEUES");
+
+-- DO THIS TEST 3 TIMES TO ALLOW FOR RANDOM VARIATIONS IN TIMING.
+ FOR I IN 1..3 LOOP
+ COMMENT ("ITERATION" & INTEGER'IMAGE(I));
+
+ DECLARE
+
+ TASK TYPE CALLERS IS
+ ENTRY NAME (N : NATURAL);
+ END CALLERS;
+
+ TASK QUEUE IS
+ ENTRY GO;
+ ENTRY E1 (NAME : NATURAL);
+ END QUEUE;
+
+ TASK DISPATCH IS
+ ENTRY READY;
+ END DISPATCH;
+
+ TASK BODY CALLERS IS
+ MY_NAME : NATURAL;
+ BEGIN
+
+-- GET NAME OF THIS TASK OBJECT
+ ACCEPT NAME (N : NATURAL) DO
+ MY_NAME := N;
+ END NAME;
+
+-- PUT THIS TASK ON QUEUE FOR QUEUE.E1
+ QUEUE.E1 (MY_NAME);
+ END CALLERS;
+
+ TASK BODY DISPATCH IS
+ TYPE ACC_CALLERS IS ACCESS CALLERS;
+ OBJ : ACC_CALLERS;
+ BEGIN
+
+-- FIRE UP TWO CALLERS FOR QUEUE.E1
+ OBJ := NEW CALLERS;
+ OBJ.NAME(1);
+ OBJ := NEW CALLERS;
+ OBJ.NAME(2);
+
+-- ALLOW THESE CALLS TO BE PROCESSED (ONLY ONE WILL BE ACCEPTED).
+ QUEUE.GO;
+
+-- WAIT TILL ONE CALL HAS BEEN PROCESSED.
+ ACCEPT READY; -- CALLED FROM QUEUE
+
+-- FIRE UP THIRD CALLER
+ OBJ := NEW CALLERS;
+ OBJ.NAME(3);
+
+ END DISPATCH;
+
+ TASK BODY QUEUE IS
+ NEXT : NATURAL; -- NUMBER OF SECOND CALLER IN QUEUE.
+ BEGIN
+
+-- WAIT UNTIL TWO TASKS CALLING E1 HAVE BEEN ACTIVATED.
+ ACCEPT GO;
+
+-- WAIT FOR TWO CALLS TO BE AVAILABLE. THIS WAIT ASSUMES THAT THE
+-- CALLER TASKS WILL PROCEED IF THIS TASK IS EXECUTING A DELAY
+-- STATEMENT, ALTHOUGH THIS IS NOT STRICTLY REQUIRED BY THE STANDARD.
+ FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE
+ LOOP
+ EXIT WHEN E1'COUNT = 2;
+ DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE
+ END LOOP;
+
+ IF E1'COUNT /= 2 THEN
+ FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " &
+ "MINUTE - 1");
+ END IF;
+
+-- ASSUMING NO FAILURE, PROCESS ONE OF THE QUEUED CALLS.
+ ACCEPT E1 (NAME : NATURAL) DO
+
+-- GET NAME OF NEXT CALLER
+ CASE NAME IS
+ WHEN 1 =>
+ NEXT := 2;
+ WHEN 2 =>
+ NEXT := 1;
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED ERROR");
+ END CASE;
+ END E1;
+
+-- TELL DISPATCH TO FIRE UP NEXT CALLER (ONE IS STILL IN QUEUE).
+ DISPATCH.READY;
+
+-- WAIT FOR CALL TO ARRIVE.
+ FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE
+ LOOP
+ EXIT WHEN E1'COUNT = 2;
+ DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE
+ END LOOP;
+
+ IF E1'COUNT /= 2 THEN
+ FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " &
+ "MINUTE - 2");
+ END IF;
+
+-- ASSUMING NO FAILURE, ACCEPT SECOND CALL AND CHECK THAT IT IS FROM THE
+-- CORRECT TASK.
+ ACCEPT E1 (NAME : NATURAL) DO
+ IF NAME /= NEXT THEN
+ FAILED ("FIFO DISCIPLINE NOT OBEYED");
+ END IF;
+ END E1;
+
+-- ACCEPT THE LAST CALLER
+ ACCEPT E1 (NAME : NATURAL);
+
+ END QUEUE;
+
+ BEGIN
+ NULL;
+ END; -- ALL TASKS NOW TERMINATED.
+ END LOOP;
+
+ RESULT;
+
+END C95021A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95022a.ada b/gcc/testsuite/ada/acats/tests/c9/c95022a.ada
new file mode 100644
index 000000000..c7e4bcbe2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95022a.ada
@@ -0,0 +1,115 @@
+--C95022A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE THE
+--THE BODY OF AN ACCEPT STATEMENT.
+
+--CHECK THE CASE OF NORMAL ENTRY TERMINATION.
+
+-- JEAN-PIERRE ROSEN 25-FEB-1984
+-- JBG 6/1/84
+
+-- FOUR CLIENT TASKS CALL ONE SERVER TASK. EACH CLIENT CALLS JUST ONE
+-- ENTRY OF THE SERVER TASK. THE TEST CHECKS TO BE SURE THAT CALLS FROM
+-- DIFFERENT TASKS ARE NOT MIXED UP.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95022A IS
+
+BEGIN
+ TEST("C95022A", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " &
+ "CORRECTLY");
+ DECLARE
+
+ TASK TYPE CLIENT IS
+ ENTRY GET_ID (I : INTEGER);
+ ENTRY RESTART;
+ END CLIENT;
+
+ T_ARR : ARRAY (1..4) OF CLIENT;
+
+ TASK SERVER IS
+ ENTRY E1 (I : IN OUT INTEGER);
+ ENTRY E2 (I : IN OUT INTEGER);
+ ENTRY E3 (I : IN OUT INTEGER);
+ ENTRY E4 (I : IN OUT INTEGER);
+ END SERVER;
+
+ TASK BODY SERVER IS
+ BEGIN
+
+ ACCEPT E1 (I : IN OUT INTEGER) DO
+ ACCEPT E2 (I : IN OUT INTEGER) DO
+ I := IDENT_INT(I);
+ ACCEPT E3 (I : IN OUT INTEGER) DO
+ ACCEPT E4 (I : IN OUT INTEGER) DO
+ I := IDENT_INT(I);
+ END E4;
+ I := IDENT_INT(I);
+ END E3;
+ END E2;
+ I := IDENT_INT(I);
+ END E1;
+
+ FOR I IN 1 .. 4 LOOP
+ T_ARR(I).RESTART;
+ END LOOP;
+ END SERVER;
+
+ TASK BODY CLIENT IS
+ ID : INTEGER;
+ SAVE_ID : INTEGER;
+ BEGIN
+ ACCEPT GET_ID (I : INTEGER) DO
+ ID := I;
+ END GET_ID;
+
+ SAVE_ID := ID;
+
+ CASE ID IS
+ WHEN 1 => SERVER.E1(ID);
+ WHEN 2 => SERVER.E2(ID);
+ WHEN 3 => SERVER.E3(ID);
+ WHEN 4 => SERVER.E4(ID);
+ WHEN OTHERS => FAILED("INCORRECT ID");
+ END CASE;
+
+ ACCEPT RESTART; -- WAIT FOR ALL TASKS TO HAVE COMPLETED
+ -- RENDEZVOUS
+ IF ID /= SAVE_ID THEN
+ FAILED("SCRAMBLED EMBEDDED RENDEZVOUS");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS => FAILED("EXCEPTION IN CLIENT");
+ END CLIENT;
+
+ BEGIN
+ FOR I IN 1 .. 4 LOOP
+ T_ARR(I).GET_ID(I);
+ END LOOP;
+ END;
+
+ RESULT;
+
+END C95022A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95022b.ada b/gcc/testsuite/ada/acats/tests/c9/c95022b.ada
new file mode 100644
index 000000000..cd1e3ff5b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95022b.ada
@@ -0,0 +1,112 @@
+-- C95022B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE
+-- THE BODY OF AN ACCEPT STATEMENT.
+
+-- CHECK THE CASE OF ABORT DURING THE INNERMOST ACCEPT.
+
+-- JEAN-PIERRE ROSEN 25-FEB-1984
+-- JBG 6/1/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95022B IS
+
+BEGIN
+
+ TEST("C95022B", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " &
+ "CORRECTLY (ABORT CASE)");
+ DECLARE
+ TASK TYPE CLIENT IS
+ ENTRY GET_ID (I : INTEGER);
+ END CLIENT;
+
+ T_ARR : ARRAY (1..4) OF CLIENT;
+
+ TASK KILL IS
+ ENTRY ME;
+ END KILL;
+
+ TASK SERVER IS
+ ENTRY E1;
+ ENTRY E2;
+ ENTRY E3;
+ ENTRY E4;
+ END SERVER;
+
+ TASK BODY SERVER IS
+ BEGIN
+
+ ACCEPT E1 DO
+ ACCEPT E2 DO
+ ACCEPT E3 DO
+ ACCEPT E4 DO
+ KILL.ME;
+ E1; -- WILL DEADLOCK UNTIL ABORT.
+ END E4;
+ END E3;
+ END E2;
+ END E1;
+
+ END SERVER;
+
+ TASK BODY KILL IS
+ BEGIN
+ ACCEPT ME;
+ ABORT SERVER;
+ END;
+
+ TASK BODY CLIENT IS
+ ID : INTEGER;
+ BEGIN
+ ACCEPT GET_ID( I : INTEGER) DO
+ ID := I;
+ END GET_ID;
+
+ CASE ID IS
+ WHEN 1 => SERVER.E1;
+ WHEN 2 => SERVER.E2;
+ WHEN 3 => SERVER.E3;
+ WHEN 4 => SERVER.E4;
+ WHEN OTHERS => FAILED ("INCORRECT ID");
+ END CASE;
+
+ FAILED ("TASKING_ERROR NOT RAISED IN CLIENT" &
+ INTEGER'IMAGE(ID));
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("EXCEPTION IN CLIENT" & INTEGER'IMAGE(ID));
+ END CLIENT;
+ BEGIN
+ FOR I IN 1 .. 4 LOOP
+ T_ARR(I).GET_ID(I);
+ END LOOP;
+ END;
+
+ RESULT;
+
+END C95022B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95033a.ada b/gcc/testsuite/ada/acats/tests/c9/c95033a.ada
new file mode 100644
index 000000000..53c354856
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95033a.ada
@@ -0,0 +1,74 @@
+-- C95033A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT - IN THE CASE OF AN ENTRY FAMILY - EXECUTION OF AN
+-- ACCEPT STATEMENT STARTS WITH THE EVALUATION OF AN ENTRY INDEX.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C950BGA-B.ADA
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C95033A IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+ FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ RETURN DIGT;
+ END FINIT_POS;
+
+ TASK T1 IS
+ ENTRY E1 (NATURAL RANGE 1 .. 2);
+ ENTRY BYE;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (FINIT_POS (1)) DO
+ PSPY_NUMB (2);
+ END E1;
+ ACCEPT BYE;
+ END T1;
+
+BEGIN
+ TEST ("C95033A", "EVALUATION OF ENTRY INDEX");
+
+ T1.E1 (1);
+ T1.BYE;
+ IF SPYNUMB /= 12 THEN
+ FAILED ("ENTRY INDEX NOT EVALUATED FIRST");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C95033A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95033b.ada b/gcc/testsuite/ada/acats/tests/c9/c95033b.ada
new file mode 100644
index 000000000..a72f3b6a8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95033b.ada
@@ -0,0 +1,67 @@
+-- C95033B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT EXECUTION OF AN ENTRY CALL STARTS WITH THE EVALUATION OF
+-- ANY ENTRY INDEX, FOLLOWED BY THE EVALUATION OF ANY EXPRESSION IN
+-- THE PARAMETER LIST.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C950BHA-B.ADA
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C95033B IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ RETURN DIGT;
+ END FINIT_POS;
+
+ TASK T1 IS
+ ENTRY E1 (NATURAL RANGE 1 .. 2) (P1 : IN NATURAL);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (1) (P1 : IN NATURAL);
+ END T1;
+
+BEGIN
+
+ TEST ("C95033B", "EVALUATION OF ENTRY INDEX AND OF " &
+ "EXPRESSIONS IN PARAMETER LIST");
+
+ T1.E1 (FINIT_POS (1)) (FINIT_POS (2));
+ IF SPYNUMB /= 12 THEN
+ FAILED ("ENTRY INDEX NOT EVALUATED FIRST");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C95033B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95034a.ada b/gcc/testsuite/ada/acats/tests/c9/c95034a.ada
new file mode 100644
index 000000000..c597bf25f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95034a.ada
@@ -0,0 +1,85 @@
+-- C95034A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CALLING TASK IS SUSPENDED IF THE RECEIVING TASK
+-- HAS NOT REACHED A CORRESPONDING ACCEPT STATEMENT.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C950BJA-B.ADA
+
+with Impdef;
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C95034A IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+ TASK T1 IS
+ ENTRY E1;
+ ENTRY E2;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 DO
+ PSPY_NUMB (1);
+ DELAY 1.0 * Impdef.One_Second;
+ END E1;
+ ACCEPT E2 DO
+ PSPY_NUMB (2);
+ END E2;
+ END T1;
+
+ TASK T2 IS
+ ENTRY BYE;
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ T1.E2;
+ PSPY_NUMB (3);
+ ACCEPT BYE;
+ END T2;
+
+BEGIN
+
+ TEST ("C95034A", "SUSPENSION OF CALLING TASK");
+
+ T1.E1;
+ T2.BYE;
+
+ IF SPYNUMB /= 123 THEN
+ FAILED ("ERROR DURING TASK EXECUTION");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C95034A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95034b.ada b/gcc/testsuite/ada/acats/tests/c9/c95034b.ada
new file mode 100644
index 000000000..3c491e70a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95034b.ada
@@ -0,0 +1,83 @@
+-- C95034B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CALLING TASK REMAINS SUSPENDED UNTIL THE ACCEPT
+-- STATEMENT RECEIVING THIS ENTRY CALL HAS COMPLETED THE EXECUTION OF
+-- ITS SEQUENCE OF STATEMENTS.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C950CBA-B.ADA
+
+with Impdef;
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C95034B IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 DO
+ PSPY_NUMB (1);
+ DELAY 1.0 * Impdef.One_Second;
+ PSPY_NUMB (2);
+ END E1;
+ END T1;
+
+ TASK T2 IS
+ ENTRY BYE;
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ T1.E1;
+ PSPY_NUMB (3);
+ ACCEPT BYE;
+ END T2;
+
+BEGIN
+
+ TEST ("C95034B", "TASK SUSPENSION UNTIL COMPLETION OF ACCEPT " &
+ "STATEMENT");
+
+ T2.BYE;
+
+ IF SPYNUMB /= 123 THEN
+ FAILED ("ERROR DURING TASK EXECUTION");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C95034B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95035a.ada b/gcc/testsuite/ada/acats/tests/c9/c95035a.ada
new file mode 100644
index 000000000..ce7816628
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95035a.ada
@@ -0,0 +1,78 @@
+-- C95035A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK IS SUSPENDED IF IT REACHES AN ACCEPT STATEMENT
+-- PRIOR TO ANY CALL OF THE CORRESPONDING ENTRY.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C950CAA-B.ADA
+
+with Impdef;
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C95035A IS
+
+ SUBTYPE ARG IS NATURAL RANGE 0..9;
+ SPYNUMB : NATURAL := 0;
+
+ PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS
+ BEGIN
+ SPYNUMB := 10*SPYNUMB+DIGT;
+ END PSPY_NUMB;
+
+ TASK T1 IS
+ ENTRY E1;
+ ENTRY BYE;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1;
+ PSPY_NUMB (2);
+ ACCEPT BYE;
+ END T1;
+
+ TASK T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ DELAY 1.0 * Impdef.One_Second;
+ PSPY_NUMB (1);
+ T1.E1;
+ END T2;
+
+BEGIN
+
+ TEST ("C95035A", "TASK SUSPENSION PRIOR TO ENTRY CALL");
+
+ T1.BYE;
+
+ IF SPYNUMB /= 12 THEN
+ FAILED ("ERROR DURING TASK EXECUTION");
+ COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB));
+ END IF;
+
+ RESULT;
+
+END C95035A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040a.ada b/gcc/testsuite/ada/acats/tests/c9/c95040a.ada
new file mode 100644
index 000000000..aa302bd1e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95040a.ada
@@ -0,0 +1,59 @@
+-- C95040A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED IF AN ENTRY OF A
+-- COMPLETED TASK IS CALLED.
+
+-- WEI 3/ 4/82
+-- JWC 6/28/85 RENAMED FROM C950CHA-B.ADA
+
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C95040A IS
+BEGIN
+
+ TEST ("C95040A", "ENTRY CALL OF COMPLETED TASK");
+
+BLOCK1 :
+ DECLARE
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1;
+ END T1;
+ BEGIN -- BLOCK1
+ T1.E1;
+ T1.E1;
+
+ FAILED ("DID NOT RAISE TASKING_ERROR");
+ EXCEPTION
+ WHEN TASKING_ERROR => NULL;
+ END BLOCK1;
+
+ RESULT;
+
+END C95040A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040b.ada b/gcc/testsuite/ada/acats/tests/c9/c95040b.ada
new file mode 100644
index 000000000..aee275f28
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95040b.ada
@@ -0,0 +1,63 @@
+-- C95040B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED BY A TASK IF THE
+-- TASK BECOMES COMPLETED OR ABNORMAL BEFORE ACCEPTING THE CALL.
+
+-- WEI 3/ 4/82
+-- TLB 10/30/87 RENAMED FROM C950CHC.ADA.
+
+with Impdef;
+WITH REPORT;
+ USE REPORT;
+PROCEDURE C95040B IS
+
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ DELAY 1.0 * Impdef.One_Second;
+ IF EQUAL (1, 1) THEN
+ ABORT T1;
+ END IF;
+ ACCEPT E1;
+ END T1;
+
+BEGIN
+
+ TEST ("C95040B", "TASK COMPLETION BEFORE ACCEPTING AN ENTRY CALL");
+
+ T1.E1;
+
+ FAILED ("NO EXCEPTION TASKING_ERROR RAISED");
+
+ RESULT;
+
+EXCEPTION
+ WHEN TASKING_ERROR =>
+ RESULT;
+
+END C95040B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040c.ada b/gcc/testsuite/ada/acats/tests/c9/c95040c.ada
new file mode 100644
index 000000000..cc7db5804
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95040c.ada
@@ -0,0 +1,86 @@
+-- C95040C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECKS THAT A TASK COMPLETED, BUT NOT TERMINATED (I.E. WAITING
+-- FOR TERMINATION OF A DEPENDENT TASK) IS NEITHER 'TERMINATED NOR
+-- 'CALLABLE. CALLS TO ENTRIES BELONGING TO SUCH A TASK RAISE
+-- TASKING_ERROR.
+
+-- J.P. ROSEN, ADA PROJECT, NYU
+-- JBG 6/1/84
+-- JWC 6/28/85 RENAMED FROM C9A009A-B.ADA
+-- PWN 9/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C95040C IS
+BEGIN
+
+ TEST ("C95040C", "TASKING_ERROR RAISED WHEN CALLING COMPLETED " &
+ "BUT UNTERMINATED TASK");
+
+ DECLARE
+
+ TASK T1 IS
+ ENTRY E;
+ END T1;
+
+ TASK BODY T1 IS
+
+ TASK T2 IS
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ COMMENT ("BEGIN T2");
+ T1.E; -- T1 WILL COMPLETE BEFORE THIS CALL
+ -- OR WHILE WAITING FOR THIS CALL TO
+ -- BE ACCEPTED. WILL DEADLOCK IF
+ -- TASKING_ERROR IS NOT RAISED.
+ FAILED ("NO TASKING_ERROR RAISED");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ IF T1'CALLABLE THEN
+ FAILED ("T1 STILL CALLABLE");
+ END IF;
+
+ IF T1'TERMINATED THEN -- T1 CAN'T TERMINATE
+ -- UNTIL T2 HAS
+ -- TERMINATED.
+ FAILED ("T1 TERMINATED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION");
+ END T2;
+ BEGIN
+ NULL;
+ END;
+
+ BEGIN
+ NULL;
+ END;
+
+ RESULT;
+
+END C95040C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040d.ada b/gcc/testsuite/ada/acats/tests/c9/c95040d.ada
new file mode 100644
index 000000000..cfe0a772d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95040d.ada
@@ -0,0 +1,122 @@
+-- C95040D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT TASKING_ERROR IS RAISED IN A CALLING
+-- TASK WHEN THE TASK OWNING THE ENTRY TERMINATES BEFORE RENDEZVOUS
+-- CAN OCCUR.
+
+-- CHECK THAT RE-RAISING TASKING_ERROR, ONCE TRAPPED IN THE CALLER,
+-- DOES NOT PROPAGATE OUTSIDE THE TASK BODY.
+
+-- GOM 11/29/84
+-- JWC 05/14/85
+-- PWB 02/11/86 CORRECTED CALL TO TEST TO SHOW CORRECT TEST NAME.
+-- RLB 12/15/99 REMOVED POTENTIALLY ERRONEOUS CALLS TO REPORT.COMMENT.
+
+WITH REPORT;
+USE REPORT;
+
+PROCEDURE C95040D IS
+
+ PROCEDURE DRIVER IS
+
+ TASK NEST IS
+ ENTRY OUTER;
+ ENTRY INNER;
+ END NEST;
+
+ TASK SLAVE;
+
+ TASK BODY NEST IS
+ BEGIN
+ --COMMENT("AT TOP OF 'NEST' TASK WAITING ON 'OUTER' " &
+ -- "RENDEZVOUS");
+
+ ACCEPT OUTER DO
+ --COMMENT("IN 'OUTER' RENDEZVOUS OF 'NEST' TASK " &
+ -- "ABOUT TO 'RETURN'");
+
+ RETURN; -- CAUSES 'INNER' RENDEZVOUS TO BE SKIPPED.
+
+ ACCEPT INNER DO
+ FAILED("'INNER' RENDEZVOUS OF 'NEST' TASK " &
+ "SHOULD NEVER BE PERFORMED");
+ END INNER;
+ END OUTER;
+
+ --COMMENT("'OUTER' RENDEZVOUS COMPLETED IN 'NEST' TASK " &
+ -- "AND NOW TERMINATING");
+ END NEST;
+
+ TASK BODY SLAVE IS
+ BEGIN
+ --COMMENT("AT TOP OF 'SLAVE' TASK. CALLING 'INNER' " &
+ -- "RENDEZVOUS");
+
+ NEST.INNER;
+
+ FAILED("SHOULD HAVE RAISED 'TASKING_ERROR' IN 'SLAVE' " &
+ "TASK");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ --COMMENT("'SLAVE' TASK CORRECTLY TRAPPING " &
+ -- "'TASKING_ERROR' AND RE-RAISING IT (BUT " &
+ -- "SHOULD NOT BE PROPAGATED)");
+ RAISE;
+ END SLAVE;
+
+ BEGIN -- START OF DRIVER PROCEDURE.
+
+ --COMMENT("AT TOP OF 'DRIVER'. CALLING 'OUTER' ENTRY OF " &
+ -- "'NEST' TASK");
+
+ NEST.OUTER;
+
+ --COMMENT("'OUTER' RENDEZVOUS COMPLETED. 'DRIVER' AWAITING " &
+ -- "TERMINATION OF 'NEST' AND 'SLAVE' TASKS");
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED("'TASKING_ERROR' CAUGHT IN 'DRIVER' WHEN IT " &
+ "SHOULD HAVE BEEN CAUGHT IN 'SLAVE' TASK, OR " &
+ "'TASKING_ERROR' WAS INCORRECTLY PROPAGATED BY " &
+ "'SLAVE' TASK");
+ END DRIVER;
+
+BEGIN -- START OF MAIN PROGRAM.
+
+ TEST("C95040D","CHECK THAT 'TASKING_ERROR' IS RAISED IN A " &
+ "CALLER TASK WHEN TASK OWNING THE ENTRY CANNOT " &
+ "PERFORM RENDEZVOUS. ALSO CHECK THAT " &
+ "'TASKING_ERROR', ONCE RAISED, IS NOT PROPAGATED " &
+ "OUTSIDE THE TASK BODY");
+
+ --COMMENT("MAIN PROGRAM CALLING 'DRIVER' PROCEDURE");
+
+ DRIVER;
+
+ --COMMENT("MAIN PROGRAM NOW TERMINATING");
+
+ RESULT;
+END C95040D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95041a.ada b/gcc/testsuite/ada/acats/tests/c9/c95041a.ada
new file mode 100644
index 000000000..4f676b3c4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95041a.ada
@@ -0,0 +1,97 @@
+-- C95041A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT AN ENTRY FAMILY INDEX CAN BE SPECIFIED WITH THE FORM
+-- A'RANGE.
+
+-- HISTORY:
+-- DHH 03/17/88 CREATED ORIGINAL TEST.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95041A IS
+
+ GLOBAL_A, GLOBAL_B : INTEGER;
+ GLOBAL_C, GLOBAL_D : INTEGER;
+ TYPE COLOR IS (RED, BLUE, YELLOW);
+ TYPE ARR IS ARRAY(COLOR RANGE RED .. BLUE) OF BOOLEAN;
+ ARRY : ARR;
+
+ TASK CHECK IS
+ ENTRY CHECK_LINK(ARR'RANGE)(I : INTEGER);
+ END CHECK;
+
+ TASK CHECK_OBJ IS
+ ENTRY CHECK_OBJ_LINK(ARRY'RANGE)(I : INTEGER);
+ END CHECK_OBJ;
+
+ TASK BODY CHECK IS
+ BEGIN
+ ACCEPT CHECK_LINK(RED)(I : INTEGER) DO
+ GLOBAL_A := IDENT_INT(I);
+ END;
+
+ ACCEPT CHECK_LINK(BLUE)(I : INTEGER) DO
+ GLOBAL_B := IDENT_INT(I);
+ END;
+ END CHECK;
+
+ TASK BODY CHECK_OBJ IS
+ BEGIN
+ ACCEPT CHECK_OBJ_LINK(RED)(I : INTEGER) DO
+ GLOBAL_C := IDENT_INT(I);
+ END;
+
+ ACCEPT CHECK_OBJ_LINK(BLUE)(I : INTEGER) DO
+ GLOBAL_D := IDENT_INT(I);
+ END;
+ END CHECK_OBJ;
+
+BEGIN
+ TEST("C95041A", "CHECK THAT AN ENTRY FAMILY INDEX CAN BE " &
+ "SPECIFIED WITH THE FORM A'RANGE");
+ CHECK.CHECK_LINK(RED)(10);
+ CHECK.CHECK_LINK(BLUE)(5);
+
+ CHECK_OBJ.CHECK_OBJ_LINK(RED)(10);
+ CHECK_OBJ.CHECK_OBJ_LINK(BLUE)(5);
+
+ IF GLOBAL_A /= IDENT_INT(10) THEN
+ FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE");
+ END IF;
+
+ IF GLOBAL_B /= IDENT_INT(5) THEN
+ FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE");
+ END IF;
+
+ IF GLOBAL_C /= IDENT_INT(10) THEN
+ FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE");
+ END IF;
+
+ IF GLOBAL_D /= IDENT_INT(5) THEN
+ FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE");
+ END IF;
+
+ RESULT;
+END C95041A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065a.ada b/gcc/testsuite/ada/acats/tests/c9/c95065a.ada
new file mode 100644
index 000000000..2224dddcd
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95065a.ada
@@ -0,0 +1,91 @@
+-- C95065A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED
+-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES
+-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE
+-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED.
+
+-- CASE (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
+-- INITIALIZED WITH A STATIC AGGREGATE.
+
+-- JWC 6/19/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95065A IS
+
+BEGIN
+
+ TEST ("C95065A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
+ "AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " &
+ "FORMAL PART IS ELABORATED");
+
+ BEGIN
+
+ DECLARE
+
+ TYPE A1 IS ARRAY (1 .. IDENT_INT(1), 1 .. IDENT_INT(10))
+ OF INTEGER;
+
+ TASK T IS
+ ENTRY E1 (A : A1 := ((1, 0), (0, 1)));
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E1 (A : A1 := ((1, 0), (0, 1))) DO
+ FAILED ("ACCEPT E1 EXECUTED");
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK T");
+ END T;
+
+ BEGIN
+ T.E1;
+ FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - E1");
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)");
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED");
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+END C95065A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065b.ada b/gcc/testsuite/ada/acats/tests/c9/c95065b.ada
new file mode 100644
index 000000000..81226af3a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95065b.ada
@@ -0,0 +1,91 @@
+-- C95065B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED
+-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES
+-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE
+-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED.
+
+-- CASE (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
+-- INITIALIZED WITH A STATIC VALUE.
+
+-- JWC 6/19/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95065B IS
+
+BEGIN
+
+ TEST ("C95065B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
+ "AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " &
+ "FORMAL PART IS ELABORATED");
+
+ BEGIN
+
+ DECLARE
+
+ SUBTYPE INT IS INTEGER
+ RANGE IDENT_INT(0) .. IDENT_INT(63);
+
+ TASK T IS
+ ENTRY E1 (I : INT := -1);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E1 (I : INT := -1) DO
+ FAILED ("ACCEPT E1 EXECUTED");
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK T");
+ END T;
+
+ BEGIN
+ T.E1;
+ FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - E1");
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)");
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED");
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+END C95065B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065c.ada b/gcc/testsuite/ada/acats/tests/c9/c95065c.ada
new file mode 100644
index 000000000..3a7732e87
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95065c.ada
@@ -0,0 +1,97 @@
+-- C95065C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED
+-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES
+-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE
+-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED.
+
+-- CASE (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
+-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
+
+-- JWC 6/19/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95065C IS
+
+BEGIN
+
+ TEST ("C95065C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
+ "AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " &
+ "FORMAL PART IS ELABORATED");
+
+ BEGIN
+
+ DECLARE
+
+ TYPE A1 IS ARRAY (1 .. 3) OF INTEGER
+ RANGE IDENT_INT(1) .. IDENT_INT(3);
+
+ TYPE REC IS
+ RECORD
+ I : INTEGER RANGE IDENT_INT(1)..IDENT_INT(3);
+ A : A1;
+ END RECORD;
+
+ TASK T IS
+ ENTRY E1 (R : REC := (-3,(0,2,3)));
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E1 (R : REC := (-3,(0,2,3))) DO
+ FAILED ("ACCEPT E1 EXECUTED");
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK T");
+ END T;
+
+ BEGIN
+ T.E1;
+ FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - E1");
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)");
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED");
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+END C95065C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065d.ada b/gcc/testsuite/ada/acats/tests/c9/c95065d.ada
new file mode 100644
index 000000000..36fc22c27
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95065d.ada
@@ -0,0 +1,92 @@
+-- C95065D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED
+-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES
+-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE
+-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED.
+
+-- CASE (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON
+-- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
+-- WITH A STATIC AGGREGATE.
+
+-- JWC 6/19/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95065D IS
+
+BEGIN
+
+ TEST ("C95065D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
+ "AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " &
+ "FORMAL PART IS ELABORATED");
+
+ BEGIN
+
+ DECLARE
+
+ TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER
+ RANGE IDENT_INT(1) .. IDENT_INT(2);
+
+ TASK T IS
+ ENTRY E1 (A : A1 := ((1, -1), (1, 2)));
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E1 (A : A1 := ((1, -1), (1, 2))) DO
+ FAILED ("ACCEPT E1 EXECUTED");
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK T");
+ END T;
+
+ BEGIN
+ T.E1;
+ FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - E1");
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)");
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED");
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+END C95065D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065e.ada b/gcc/testsuite/ada/acats/tests/c9/c95065e.ada
new file mode 100644
index 000000000..95086f073
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95065e.ada
@@ -0,0 +1,92 @@
+-- C95065E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED
+-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES
+-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE
+-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED.
+
+-- CASE (E) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON
+-- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
+-- WITH A STATIC AGGREGATE.
+
+-- JWC 6/19/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95065E IS
+
+BEGIN
+
+ TEST ("C95065E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
+ "AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " &
+ "FORMAL PART IS ELABORATED");
+
+ BEGIN
+
+ DECLARE
+
+ TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER
+ RANGE IDENT_INT(1) .. IDENT_INT(2);
+
+ TASK T IS
+ ENTRY E1 (A : A1 := (3 .. 4 => (1, 2)));
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E1 (A : A1 := (3 .. 4 => (1, 2))) DO
+ FAILED ("ACCEPT E1 EXECUTED");
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK T");
+ END T;
+
+ BEGIN
+ T.E1;
+ FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - E1");
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)");
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED");
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+END C95065E;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065f.ada b/gcc/testsuite/ada/acats/tests/c9/c95065f.ada
new file mode 100644
index 000000000..3451707af
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95065f.ada
@@ -0,0 +1,97 @@
+-- C95065F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED
+-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES
+-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE
+-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED.
+
+-- CASE (F) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
+-- INITIALIZED WITH A STATIC AGGREGATE.
+
+-- JWC 6/19/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95065F IS
+
+BEGIN
+
+ TEST ("C95065F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
+ "AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " &
+ "FORMAL PART IS ELABORATED");
+
+ BEGIN
+
+ DECLARE
+
+ SUBTYPE INT IS INTEGER RANGE 0 .. 10;
+ TYPE A1 IS ARRAY (1 .. 3) OF INT;
+ TYPE REC (I : INT) IS
+ RECORD
+ A : A1;
+ END RECORD;
+
+ SUBTYPE REC4 IS REC (IDENT_INT(4));
+
+ TASK T IS
+ ENTRY E1 (R : REC4 := (3,(1,2,3)));
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E1 (R : REC4 := (3,(1,2,3))) DO
+ FAILED ("ACCEPT E1 EXECUTED");
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK T");
+ END T;
+
+ BEGIN
+ T.E1;
+ FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - E1");
+ END;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)");
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED");
+ WHEN OTHERS =>
+ FAILED ("UNEXPECTED EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+END C95065F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95066a.ada b/gcc/testsuite/ada/acats/tests/c9/c95066a.ada
new file mode 100644
index 000000000..f9405d99b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95066a.ada
@@ -0,0 +1,214 @@
+-- C95066A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A STATIC EXPRESSION, CONSTANT NAME, ATTRIBUTE NAME,
+-- VARIABLE, DEREFERENCED ACCESS, USER-DEFINED OPERATOR, USER-
+-- DEFINED FUNCTION, OR ALLOCATOR CAN BE USED IN THE INITIALIZATION
+-- EXPRESSION OF A FORMAL PARAMETER, AND THAT THE APPROPRIATE
+-- VALUE IS USED AS A DEFAULT PARAMETER VALUE WHEN THE ENTRY
+-- IS CALLED.
+
+-- GLH 6/19/85
+
+WITH REPORT;
+PROCEDURE C95066A IS
+
+ USE REPORT;
+
+ TYPE INT IS RANGE 1 .. 10;
+
+ TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ A : ARR (0..CONSTRAINT);
+ END RECORD;
+
+ C7 : CONSTANT INTEGER := 7;
+ V7 : INTEGER := 7;
+
+ TYPE A_INT IS ACCESS INTEGER;
+ C_A : CONSTANT A_INT := NEW INTEGER'(7);
+
+ SUBTYPE RECTYPE1 IS RECTYPE (2 + 5);
+ SUBTYPE RECTYPE2 IS RECTYPE (C7);
+ SUBTYPE RECTYPE3 IS RECTYPE (V7);
+
+ FUNCTION "&" (X,Y : INTEGER) RETURN INTEGER IS
+ BEGIN
+ RETURN 10;
+ END "&";
+
+ FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS
+ BEGIN
+ RETURN X;
+ END FUNC;
+
+ -- STATIC EXPRESSION.
+
+ TASK T1 IS
+ ENTRY E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7)));
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) DO
+ IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR " &
+ "E1 PARAMETER");
+ END IF;
+ END E1;
+ END T1;
+
+ -- CONSTANT NAME.
+
+ TASK T2 IS
+ ENTRY E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7)));
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) DO
+ IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR " &
+ "E2 PARAMETER");
+ END IF;
+ END E2;
+ END T2;
+
+ -- ATTRIBUTE NAME.
+
+ TASK T3 IS
+ ENTRY E3 (P1 : INT := INT'LAST);
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN
+ ACCEPT E3 (P1 : INT := INT'LAST) DO
+ IF (P1 /= INT (10)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR " &
+ "E3 PARAMETER");
+ END IF;
+ END E3;
+ END T3;
+
+ -- VARIABLE.
+
+ TASK T4 IS
+ ENTRY E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7)));
+ END T4;
+
+ TASK BODY T4 IS
+ BEGIN
+ ACCEPT E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) DO
+ IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR " &
+ "E4 PARAMETER");
+ END IF;
+ END E4;
+ END T4;
+
+ -- DEREFERENCED ACCESS.
+
+ TASK T5 IS
+ ENTRY E5 (P5 : INTEGER := C_A.ALL);
+ END T5;
+
+ TASK BODY T5 IS
+ BEGIN
+ ACCEPT E5 (P5 : INTEGER := C_A.ALL) DO
+ IF (P5 /= C_A.ALL) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR " &
+ "E5 PARAMETER");
+ END IF;
+ END E5;
+ END T5;
+
+ -- USER-DEFINED OPERATOR.
+
+ TASK T6 IS
+ ENTRY E6 (P6 : INTEGER := 6&4);
+ END T6;
+
+ TASK BODY T6 IS
+ BEGIN
+ ACCEPT E6 (P6 : INTEGER := 6&4) DO
+ IF (P6 /= IDENT_INT(10)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE " &
+ "FOR E6 PARAMETER");
+ END IF;
+ END E6;
+ END T6;
+
+ -- USER-DEFINED FUNCTION.
+
+ TASK T7 IS
+ ENTRY E7 (P7 : INTEGER := FUNC(10));
+ END T7;
+
+ TASK BODY T7 IS
+ BEGIN
+ ACCEPT E7 (P7 : INTEGER := FUNC(10)) DO
+ IF (P7 /= IDENT_INT(10)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR " &
+ "E7 PARAMETER");
+ END IF;
+ END E7;
+ END T7;
+
+ -- ALLOCATOR.
+
+ TASK T8 IS
+ ENTRY E8 (P8 : A_INT := NEW INTEGER'(7));
+ END T8;
+
+ TASK BODY T8 IS
+ BEGIN
+ ACCEPT E8 (P8 : A_INT := NEW INTEGER'(7)) DO
+ IF (P8.ALL /= IDENT_INT(7)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE " &
+ "FOR E8 PARAMETER");
+ END IF;
+ END E8;
+ END T8;
+
+BEGIN
+ TEST ("C95066A", "CHECK USE OF STATIC EXPRESSIONS, CONSTANT " &
+ "NAMES, ATTRIBUTE NAMES, VARIABLES, USER- " &
+ "DEFINED OPERATORS, USER-DEFINED FUNCTIONS, " &
+ "DEREFERENCED ACCESSES, AND ALLOCATORS IN " &
+ "THE FORMAL PART OF A TASK SPECIFICATION");
+
+ T1.E1;
+ T2.E2;
+ T3.E3;
+ T4.E4;
+ T5.E5;
+ T6.E6;
+ T7.E7;
+ T8.E8;
+
+ RESULT;
+
+END C95066A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95067a.ada b/gcc/testsuite/ada/acats/tests/c9/c95067a.ada
new file mode 100644
index 000000000..d4393d51d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95067a.ada
@@ -0,0 +1,302 @@
+-- C95067A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A FORMAL PARAMETER OF MODE IN OR IN OUT CAN BE OF A
+-- LIMITED TYPE, INCLUDING A COMPOSITE LIMITED TYPE.
+
+-- JWC 6/20/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95067A IS
+
+ PACKAGE PKG IS
+
+ TYPE ITYPE IS LIMITED PRIVATE;
+
+ TASK T1 IS
+
+ ENTRY LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING);
+
+ ENTRY LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
+ M : STRING);
+
+ ENTRY SET_I (X : IN OUT ITYPE; V : INTEGER);
+
+ END T1;
+
+ SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20;
+ TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE;
+
+ TASK T2 IS
+
+ ENTRY LOOK_IN_VR (X : IN VRTYPE; C : INTEGER;
+ I : INTEGER; S : STRING; M : STRING);
+
+ ENTRY LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
+ I : INTEGER; S : STRING;
+ M : STRING);
+
+ ENTRY SET_VR (X : IN OUT VRTYPE; C : INTEGER;
+ I : INTEGER; S : STRING);
+
+ END T2;
+
+ PRIVATE
+
+ TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99;
+
+ TYPE VRTYPE (C : INT_0_20 := 20) IS
+ RECORD
+ I : INTEGER;
+ S : STRING (1 .. C);
+ END RECORD;
+
+ END PKG;
+
+ USE PKG;
+
+ I1 : ITYPE;
+
+ TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE;
+
+ A1 : ATYPE;
+
+ VR1 : VRTYPE;
+
+ D : CONSTANT INT_0_20 := 10;
+
+ TYPE RTYPE IS
+ RECORD
+ J : ITYPE;
+ R : VRTYPE (D);
+ END RECORD;
+
+ R1 : RTYPE;
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T1 IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT LOOK_IN_I (X : IN ITYPE; V : INTEGER;
+ M : STRING) DO
+ IF INTEGER (X) /= V THEN
+ FAILED ("WRONG SCALAR VALUE - " & M);
+ END IF;
+ END LOOK_IN_I;
+ OR
+ ACCEPT LOOK_INOUT_I (X : IN OUT ITYPE;
+ V : INTEGER;
+ M : STRING) DO
+ IF INTEGER (X) /= V THEN
+ FAILED ("WRONG SCALAR VALUE - " & M);
+ END IF;
+ END LOOK_INOUT_I;
+ OR
+ ACCEPT SET_I (X : IN OUT ITYPE; V : INTEGER) DO
+ X := ITYPE (IDENT_INT (V));
+ END SET_I;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT LOOK_IN_VR (X : IN VRTYPE; C : INTEGER;
+ I : INTEGER; S : STRING;
+ M : STRING) DO
+ IF (X.C /= C OR X.I /= I) OR ELSE
+ X.S /= S THEN
+ FAILED ("WRONG COMPOSITE VALUE - " &
+ M);
+ END IF;
+ END LOOK_IN_VR;
+ OR
+ ACCEPT LOOK_INOUT_VR (X : IN OUT VRTYPE;
+ C : INTEGER; I : INTEGER;
+ S : STRING;
+ M : STRING) DO
+ IF (X.C /= C OR X.I /= I) OR ELSE
+ X.S /= S THEN
+ FAILED ("WRONG COMPOSITE VALUE - " &
+ M);
+ END IF;
+ END LOOK_INOUT_VR;
+ OR
+ ACCEPT SET_VR (X : IN OUT VRTYPE; C : INTEGER;
+ I : INTEGER; S : STRING) DO
+ X := (IDENT_INT(C), IDENT_INT(I),
+ IDENT_STR(S));
+ END SET_VR;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T2;
+
+ BEGIN
+ I1 := ITYPE (IDENT_INT(2));
+
+ FOR I IN A1'RANGE LOOP
+ A1 (I) := ITYPE (3 + IDENT_INT(I));
+ END LOOP;
+
+ VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234"));
+
+ R1.J := ITYPE (IDENT_INT(6));
+ R1.R := (IDENT_INT(D), IDENT_INT(19),
+ IDENT_STR("ABCDEFGHIJ"));
+ END PKG;
+
+ TASK T3 IS
+ ENTRY CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING);
+
+ ENTRY CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER;
+ NV : INTEGER; M : STRING);
+
+ ENTRY CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING);
+
+ ENTRY CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER;
+ NV : INTEGER; M : STRING);
+
+ ENTRY CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
+ S : STRING; M : STRING);
+
+ ENTRY CHECK_INOUT_VR (X : IN OUT VRTYPE;
+ OC : INTEGER; OI : INTEGER; OS : STRING;
+ NC : INTEGER; NI : INTEGER; NS : STRING;
+ M : STRING);
+
+ ENTRY CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER;
+ I : INTEGER; S : STRING; M : STRING);
+
+ ENTRY CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER;
+ OC : INTEGER; OI : INTEGER; OS : STRING;
+ NJ : INTEGER;
+ NC : INTEGER; NI : INTEGER; NS : STRING;
+ M : STRING);
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN
+ ACCEPT CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) DO
+ T1.LOOK_IN_I (X, V, M);
+ END CHECK_IN_I;
+
+ ACCEPT CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER;
+ NV : INTEGER; M : STRING) DO
+ T1.LOOK_INOUT_I (X, OV, M & " - A");
+ T1.SET_I (X, NV);
+ T1.LOOK_INOUT_I (X, NV, M & " - B");
+ T1.LOOK_IN_I (X, NV, M & " - C");
+ END CHECK_INOUT_I;
+
+ ACCEPT CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) DO
+ FOR I IN X'RANGE LOOP
+ T1.LOOK_IN_I (X(I), V+I, M & " -" &
+ INTEGER'IMAGE (I));
+ END LOOP;
+ END CHECK_IN_A;
+
+ ACCEPT CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER;
+ NV : INTEGER; M : STRING) DO
+ FOR I IN X'RANGE LOOP
+ T1.LOOK_INOUT_I (X(I), OV+I, M & " - A" &
+ INTEGER'IMAGE (I));
+ T1.SET_I (X(I), NV+I);
+ T1.LOOK_INOUT_I (X(I), NV+I, M & " - B" &
+ INTEGER'IMAGE (I));
+ T1.LOOK_IN_I (X(I), NV+I, M & " - C" &
+ INTEGER'IMAGE (I));
+ END LOOP;
+ END CHECK_INOUT_A;
+
+ ACCEPT CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
+ S : STRING; M : STRING) DO
+ T2.LOOK_IN_VR (X, C, I, S, M);
+ END CHECK_IN_VR;
+
+ ACCEPT CHECK_INOUT_VR (X : IN OUT VRTYPE;
+ OC : INTEGER; OI : INTEGER;
+ OS : STRING;
+ NC : INTEGER; NI : INTEGER;
+ NS : STRING;
+ M : STRING) DO
+ T2.LOOK_INOUT_VR (X, OC, OI, OS, M & " - A");
+ T2.SET_VR (X, NC, NI, NS);
+ T2.LOOK_INOUT_VR (X, NC, NI, NS, M & " - B");
+ T2.LOOK_IN_VR (X, NC, NI, NS, M & " - C");
+ END CHECK_INOUT_VR;
+
+ ACCEPT CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER;
+ I : INTEGER; S : STRING; M : STRING) DO
+ T1.LOOK_IN_I (X.J, J, M & " - A");
+ T2.LOOK_IN_VR (X.R, C, I, S, M & " - B");
+ END CHECK_IN_R;
+
+ ACCEPT CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER;
+ OC : INTEGER; OI : INTEGER; OS : STRING;
+ NJ : INTEGER;
+ NC : INTEGER; NI : INTEGER; NS : STRING;
+ M : STRING) DO
+ T1.LOOK_INOUT_I (X.J, OJ, M & " - A");
+ T2.LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B");
+ T1.SET_I (X.J, NJ);
+ T2.SET_VR (X.R, NC, NI, NS);
+ T1.LOOK_INOUT_I (X.J, NJ, M & " - C");
+ T2.LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D");
+ T1.LOOK_IN_I (X.J, NJ, M & " - E");
+ T2.LOOK_IN_VR (X.R, NC, NI, NS, M & " - F");
+ END CHECK_INOUT_R;
+ END T3;
+
+BEGIN
+ TEST ("C95067A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " &
+ "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS");
+
+ T3.CHECK_IN_I (I1, 2, "IN I");
+
+ T3.CHECK_INOUT_I (I1, 2, 5, "INOUT I");
+
+ T3.CHECK_IN_A (A1, 3, "IN A");
+
+ T3.CHECK_INOUT_A (A1, 3, 17, "INOUT A");
+
+ T3.CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR");
+
+ T3.CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210",
+ "INOUT VR");
+
+ T3.CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R");
+
+ T3.CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5,
+ "ZYXWVUTSRQ", "INOUT R");
+
+ RESULT;
+END C95067A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95071a.ada b/gcc/testsuite/ada/acats/tests/c9/c95071a.ada
new file mode 100644
index 000000000..a7153993d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95071a.ada
@@ -0,0 +1,230 @@
+-- C95071A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT OBJECTS DESIGNATED BY IN PARAMETERS OF ACCESS TYPES CAN
+-- BE USED AS THE TARGET OF AN ASSIGNMENT STATEMENT AND AS AN ACTUAL
+-- PARAMETER OF ANY MODE. SUBTESTS ARE:
+-- (A) INTEGER ACCESS TYPE.
+-- (B) ARRAY ACCESS TYPE.
+-- (C) RECORD ACCESS TYPE.
+
+-- JWC 7/11/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95071A IS
+
+BEGIN
+
+ TEST ("C95071A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS " &
+ "MAY BE USED IN ASSIGNMENT CONTEXTS");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE PTRINT IS ACCESS INTEGER;
+ PI : PTRINT;
+
+ TASK TA IS
+ ENTRY EA (PI : IN PTRINT);
+ END TA;
+
+ TASK BODY TA IS
+ BEGIN
+ ACCEPT EA (PI : IN PTRINT) DO
+ DECLARE
+ TASK TA1 IS
+ ENTRY EA1 (I : OUT INTEGER);
+ ENTRY EA2 (I : IN OUT INTEGER);
+ END TA1;
+
+ TASK BODY TA1 IS
+ BEGIN
+ ACCEPT EA1 (I : OUT INTEGER) DO
+ I := 7;
+ END EA1;
+
+ ACCEPT EA2 (I : IN OUT INTEGER) DO
+ I := I + 1;
+ END EA2;
+ END TA1;
+
+ BEGIN
+ TA1.EA1 (PI.ALL);
+ TA1.EA2 (PI.ALL);
+ PI.ALL := PI.ALL + 1;
+ IF (PI.ALL /= 9) THEN
+ FAILED ("ASSIGNMENT TO COMPONENT OF " &
+ "INTEGER ACCESS PARAMETER " &
+ "FAILED");
+ END IF;
+ END;
+ END EA;
+ END TA;
+
+ BEGIN -- (A)
+
+ PI := NEW INTEGER'(0);
+ TA.EA (PI);
+
+ END; -- (A)
+
+ ---------------------------------------------
+
+ DECLARE -- (B)
+
+ TYPE TBL IS ARRAY (1..3) OF INTEGER;
+ TYPE PTRTBL IS ACCESS TBL;
+ PT : PTRTBL;
+
+ TASK TB IS
+ ENTRY EB (PT : IN PTRTBL);
+ END TB;
+
+ TASK BODY TB IS
+ BEGIN
+ ACCEPT EB (PT : IN PTRTBL) DO
+ DECLARE
+ TASK TB1 IS
+ ENTRY EB1 (T : OUT TBL);
+ ENTRY EB2 (T : IN OUT TBL);
+ ENTRY EB3 (I : OUT INTEGER);
+ ENTRY EB4 (I : IN OUT INTEGER);
+ END TB1;
+
+ TASK BODY TB1 IS
+ BEGIN
+ ACCEPT EB1 (T : OUT TBL) DO
+ T := (1,2,3);
+ END EB1;
+
+ ACCEPT EB2 (T : IN OUT TBL) DO
+ T(3) := T(3) - 1;
+ END EB2;
+
+ ACCEPT EB3 (I : OUT INTEGER) DO
+ I := 7;
+ END EB3;
+
+ ACCEPT EB4 (I : IN OUT INTEGER) DO
+ I := I + 1;
+ END EB4;
+ END TB1;
+
+ BEGIN
+ TB1.EB1 (PT.ALL); -- (1,2,3)
+ TB1.EB2 (PT.ALL); -- (1,2,2)
+ TB1.EB3 (PT(2)); -- (1,7,2)
+ TB1.EB4 (PT(1)); -- (2,7,2)
+ PT(3) := PT(3) + 7; -- (2,7,9)
+ IF (PT.ALL /= (2,7,9)) THEN
+ FAILED ("ASSIGNMENT TO COMPONENT OF " &
+ "ARRAY ACCESS PARAMETER FAILED");
+ END IF;
+ END;
+ END EB;
+ END TB;
+
+ BEGIN -- (B)
+
+ PT := NEW TBL'(0,0,0);
+ TB.EB (PT);
+
+ END; -- (B)
+
+ ---------------------------------------------
+
+ DECLARE -- (C)
+
+ TYPE REC IS
+ RECORD
+ I1 : INTEGER;
+ I2 : INTEGER;
+ I3 : INTEGER;
+ END RECORD;
+
+ TYPE PTRREC IS ACCESS REC;
+ PR : PTRREC;
+
+ TASK TC IS
+ ENTRY EC (PR : IN PTRREC);
+ END TC;
+
+ TASK BODY TC IS
+ BEGIN
+ ACCEPT EC (PR : IN PTRREC) DO
+ DECLARE
+ TASK TC1 IS
+ ENTRY EC1 (R : OUT REC);
+ ENTRY EC2 (R : IN OUT REC);
+ ENTRY EC3 (I : OUT INTEGER);
+ ENTRY EC4 (I : IN OUT INTEGER);
+ END TC1;
+
+ TASK BODY TC1 IS
+ BEGIN
+ ACCEPT EC1 (R : OUT REC) DO
+ R := (1,2,3);
+ END EC1;
+
+ ACCEPT EC2 (R : IN OUT REC) DO
+ R.I3 := R.I3 - 1;
+ END EC2;
+
+ ACCEPT EC3 (I : OUT INTEGER) DO
+ I := 7;
+ END EC3;
+
+ ACCEPT EC4 (I : IN OUT INTEGER) DO
+ I := I + 1;
+ END EC4;
+ END TC1;
+
+ BEGIN
+ TC1.EC1 (PR.ALL); -- (1,2,3)
+ TC1.EC2 (PR.ALL); -- (1,2,2)
+ TC1.EC3 (PR.I2); -- (1,7,2)
+ TC1.EC4 (PR.I1); -- (2,7,2)
+ PR.I3 := PR.I3 + 7; -- (2,7,9)
+ IF (PR.ALL /= (2,7,9)) THEN
+ FAILED ("ASSIGNMENT TO COMPONENT OF " &
+ "RECORD ACCESS PARAMETER " &
+ "FAILED");
+ END IF;
+ END;
+ END EC;
+ END TC;
+
+ BEGIN -- (C)
+
+ PR := NEW REC'(0,0,0);
+ TC.EC (PR);
+
+ END; -- (C)
+
+ ---------------------------------------------
+
+ RESULT;
+
+END C95071A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95072a.ada b/gcc/testsuite/ada/acats/tests/c9/c95072a.ada
new file mode 100644
index 000000000..261007b27
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95072a.ada
@@ -0,0 +1,197 @@
+-- C95072A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT SCALAR AND ACCESS PARAMETERS ARE COPIED FOR ALL THREE
+-- PARAMETER MODES.
+-- SUBTESTS ARE:
+-- (A) SCALAR PARAMETERS TO ENTRIES.
+-- (B) ACCESS PARAMETERS TO ENTRIES.
+
+-- JWC 7/22/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95072A IS
+
+BEGIN
+ TEST ("C95072A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " &
+ "COPIED");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ I : INTEGER;
+ E : EXCEPTION;
+
+ TASK TA IS
+ ENTRY EA (EI : IN INTEGER; EO : OUT INTEGER;
+ EIO : IN OUT INTEGER);
+ END TA;
+
+ TASK BODY TA IS
+
+ TMP : INTEGER;
+
+ BEGIN
+
+ ACCEPT EA (EI : IN INTEGER; EO : OUT INTEGER;
+ EIO : IN OUT INTEGER) DO
+
+ TMP := EI; -- SAVE VALUE OF EI AT ACCEPT.
+
+ EO := 10;
+ IF EI /= TMP THEN
+ FAILED ("ASSIGNMENT TO SCALAR OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := EI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ EIO := EIO + 100;
+ IF EI /= TMP THEN
+ FAILED ("ASSIGNMENT TO SCALAR IN OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := EI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ I := I + 1;
+ IF EI /= TMP THEN
+ FAILED ("ASSIGNMENT TO SCALAR ACTUAL " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION HANDLING.
+ END EA;
+
+ EXCEPTION
+ WHEN OTHERS => NULL;
+ END TA;
+
+ BEGIN -- (A)
+
+ I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED.
+ TA.EA (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - A");
+
+ EXCEPTION
+ WHEN E =>
+ IF I /= 1 THEN
+ CASE I IS
+ WHEN 11 =>
+ FAILED ("OUT ACTUAL SCALAR PARAMETER " &
+ "CHANGED GLOBAL VALUE");
+ WHEN 101 =>
+ FAILED ("IN OUT ACTUAL SCALAR " &
+ "PARAMETER CHANGED GLOBAL VALUE");
+ WHEN 111 =>
+ FAILED ("OUT AND IN OUT ACTUAL SCALAR " &
+ "PARAMETERS CHANGED GLOBAL " &
+ "VALUE");
+ WHEN OTHERS =>
+ FAILED ("UNDETERMINED CHANGE TO GLOBAL " &
+ "VALUE");
+ END CASE;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - A");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ TYPE ACCTYPE IS ACCESS INTEGER;
+
+ I : ACCTYPE;
+ E : EXCEPTION;
+
+ TASK TB IS
+ ENTRY EB (EI : IN ACCTYPE; EO : OUT ACCTYPE;
+ EIO : IN OUT ACCTYPE);
+ END TB;
+
+ TASK BODY TB IS
+
+ TMP : ACCTYPE;
+
+ BEGIN
+
+ ACCEPT EB (EI : IN ACCTYPE; EO : OUT ACCTYPE;
+ EIO : IN OUT ACCTYPE) DO
+
+ TMP := EI; -- SAVE VALUE OF EI AT ACCEPT.
+
+ I := NEW INTEGER'(101);
+ IF EI /= TMP THEN
+ FAILED ("ASSIGNMENT TO ACCESS ACTUAL " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := EI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ EO := NEW INTEGER'(1);
+ IF EI /= TMP THEN
+ FAILED ("ASSIGNMENT TO ACCESS OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := EI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ EIO := NEW INTEGER'(10);
+ IF EI /= TMP THEN
+ FAILED ("ASSIGNMENT TO ACCESS IN OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION HANDLING.
+ END EB;
+
+ EXCEPTION
+ WHEN OTHERS => NULL;
+ END TB;
+
+ BEGIN -- (B)
+
+ I := NEW INTEGER'(100);
+ TB.EB (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - B");
+
+ EXCEPTION
+ WHEN E =>
+ IF I.ALL /= 101 THEN
+ FAILED ("OUT OR IN OUT ACTUAL ENTRY " &
+ "PARAMETER VALUE CHANGED DESPITE " &
+ "RAISED EXCEPTION");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - B");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ RESULT;
+END C95072A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95072b.ada b/gcc/testsuite/ada/acats/tests/c9/c95072b.ada
new file mode 100644
index 000000000..ba1b91ed1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95072b.ada
@@ -0,0 +1,278 @@
+-- C95072B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE
+-- PASSED BY COPY FOR ALL MODES.
+-- SUBTESTS ARE:
+-- (A) PRIVATE SCALAR PARAMETERS TO ENTRIES.
+-- (B) PRIVATE ACCESS PARAMETERS TO ENTRIES.
+
+-- JWC 7/22/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95072B IS
+
+BEGIN
+ TEST("C95072B", "CHECK THAT PRIVATE SCALAR AND ACCESS " &
+ "PARAMETERS ARE COPIED");
+
+ ---------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE SCALAR_PKG IS
+
+ TYPE T IS PRIVATE;
+ C0 : CONSTANT T;
+ C1 : CONSTANT T;
+ C10 : CONSTANT T;
+ C100 : CONSTANT T;
+
+ FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T;
+ FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER;
+
+ PRIVATE
+
+ TYPE T IS NEW INTEGER;
+ C0 : CONSTANT T := 0;
+ C1 : CONSTANT T := 1;
+ C10 : CONSTANT T := 10;
+ C100 : CONSTANT T := 100;
+
+ END SCALAR_PKG;
+
+ PACKAGE BODY SCALAR_PKG IS
+
+ FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS
+ BEGIN
+ RETURN T (INTEGER(OLD) + INTEGER(INCREMENT));
+ END "+";
+
+ FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS
+ BEGIN
+ RETURN INTEGER (OLD_PRIVATE);
+ END CONVERT;
+
+ END SCALAR_PKG;
+
+ USE SCALAR_PKG;
+
+ BEGIN -- (A)
+
+ DECLARE -- (A1)
+
+ I : T;
+ E : EXCEPTION;
+
+ TASK TA IS
+ ENTRY EA (EI : IN T; EO : OUT T;
+ EIO : IN OUT T);
+ END TA;
+
+ TASK BODY TA IS
+
+ TEMP : T;
+
+ BEGIN
+
+ ACCEPT EA (EI : IN T; EO : OUT T;
+ EIO : IN OUT T) DO
+
+ TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT.
+
+ EO := C10;
+ IF EI /= TEMP THEN
+ FAILED ("ASSIGNMENT TO PRIVATE " &
+ "(SCALAR) OUT PARAMETER " &
+ "CHANGES THE VALUE OF INPUT " &
+ "PARAMETER");
+ TEMP := EI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ EIO := EIO + C100;
+ IF EI /= TEMP THEN
+ FAILED ("ASSIGNMENT TO PRIVATE " &
+ "(SCALAR) IN OUT PARAMETER " &
+ "CHANGES THE VALUE OF INPUT " &
+ "PARAMETER");
+ TEMP := EI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ I := I + C1;
+ IF EI /= TEMP THEN
+ FAILED ("ASSIGNMENT TO PRIVATE " &
+ "(SCALAR) ACTUAL PARAMETER " &
+ "CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION
+ -- HANDLING.
+ END EA;
+
+ EXCEPTION
+ WHEN OTHERS => NULL;
+ END TA;
+
+ BEGIN -- (A1)
+
+ I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE
+ -- DETECTED.
+ TA.EA (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - A");
+
+ EXCEPTION
+ WHEN E =>
+ IF I /= C1 THEN
+ CASE CONVERT (I) IS
+ WHEN 11 =>
+ FAILED ("OUT ACTUAL PRIVATE " &
+ "(SCALAR) PARAMETER " &
+ "CHANGED GLOBAL VALUE");
+ WHEN 101 =>
+ FAILED ("IN OUT ACTUAL PRIVATE " &
+ "(SCALAR) PARAMETER " &
+ "CHANGED GLOBAL VALUE");
+ WHEN 111 =>
+ FAILED ("OUT AND IN OUT ACTUAL " &
+ "PRIVATE (SCALAR) " &
+ "PARAMETER CHANGED " &
+ "GLOBAL VALUE");
+ WHEN OTHERS =>
+ FAILED ("UNDETERMINED CHANGE TO " &
+ "GLOBAL VALUE");
+ END CASE;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - A");
+ END; -- (A1)
+
+ END; -- (A)
+
+ ---------------------------------------------------
+
+ DECLARE -- (B)
+
+ PACKAGE ACCESS_PKG IS
+
+ TYPE T IS PRIVATE;
+ C_NULL : CONSTANT T;
+ C1 : CONSTANT T;
+ C10 : CONSTANT T;
+ C100 : CONSTANT T;
+ C101 : CONSTANT T;
+
+ PRIVATE
+
+ TYPE T IS ACCESS INTEGER;
+ C_NULL : CONSTANT T := NULL;
+ C1 : CONSTANT T := NEW INTEGER'(1);
+ C10 : CONSTANT T := NEW INTEGER'(10);
+ C100 : CONSTANT T := NEW INTEGER'(100);
+ C101 : CONSTANT T := NEW INTEGER'(101);
+
+ END ACCESS_PKG;
+
+ USE ACCESS_PKG;
+
+ BEGIN -- (B)
+
+ DECLARE -- (B1)
+
+ I : T;
+ E : EXCEPTION;
+
+ TASK TB IS
+ ENTRY EB (EI : IN T; EO : OUT T;
+ EIO : IN OUT T);
+ END TB;
+
+ TASK BODY TB IS
+
+ TEMP : T;
+
+ BEGIN
+
+ ACCEPT EB (EI : IN T; EO : OUT T;
+ EIO : IN OUT T) DO
+
+ TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT.
+
+ I := C101;
+ IF EI /= TEMP THEN
+ FAILED ("ASSIGNMENT TO PRIVATE " &
+ "(ACCESS) ACTUAL VARIABLE " &
+ "CHANGES THE VALUE OF INPUT " &
+ "PARAMETER");
+ TEMP := EI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ EO := C1;
+ IF EI /= TEMP THEN
+ FAILED ("ASSIGNMENT TO PRIVATE " &
+ "(ACCESS) OUT PARAMETER " &
+ "CHANGES THE VALUE OF INPUT " &
+ "PARAMETER");
+ TEMP := EI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ EIO := C10;
+ IF EI /= TEMP THEN
+ FAILED ("ASSIGNMENT TO PRIVATE " &
+ "(ACCESS) IN OUT PARAMETER " &
+ "CHANGES THE VALUE OF INPUT " &
+ "PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION
+ -- HANDLING.
+ END EB;
+
+ EXCEPTION
+ WHEN OTHERS => NULL;
+ END TB;
+
+ BEGIN -- (B1)
+
+ I := C100;
+ TB.EB (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - B");
+
+ EXCEPTION
+ WHEN E =>
+ IF I /= C101 THEN
+ FAILED ("OUT OR IN OUT ACTUAL ENTRY " &
+ "PARAMETER VALUE CHANGED DESPITE " &
+ "RAISED EXCEPTION");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - B");
+ END; -- (B1)
+
+ END; -- (B)
+
+ ---------------------------------------------------
+
+ RESULT;
+END C95072B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95073a.ada b/gcc/testsuite/ada/acats/tests/c9/c95073a.ada
new file mode 100644
index 000000000..f8b1e0daf
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95073a.ada
@@ -0,0 +1,66 @@
+-- C95073A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ALIASING IS PERMITTED FOR PARAMETERS OF COMPOSITE TYPES,
+-- E.G., THAT A MATRIX ADDITION PROCEDURE CAN BE CALLED WITH THREE
+-- IDENTICAL ARGUMENTS.
+
+-- JWC 7/29/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95073A IS
+
+ TYPE MATRIX IS ARRAY (1..3, 1..3) OF INTEGER;
+
+ A : MATRIX := ((1,2,3), (4,5,6), (7,8,9));
+
+ TASK T IS
+ ENTRY MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) DO
+ FOR I IN 1..3 LOOP
+ FOR J IN 1..3 LOOP
+ SUM (I,J) := X (I,J) + Y (I,J);
+ END LOOP;
+ END LOOP;
+ END MAT_ADD;
+ END T;
+
+BEGIN
+
+ TEST ("C95073A", "CHECK THAT ALIASING IS PERMITTED FOR " &
+ "PARAMETERS OF COMPOSITE TYPES");
+
+ T.MAT_ADD (A, A, A);
+
+ IF A /= ((2,4,6), (8,10,12), (14,16,18)) THEN
+ FAILED ("THE RESULT OF THE MATRIX ADDITION IS INCORRECT");
+ END IF;
+
+ RESULT;
+
+END C95073A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95074c.ada b/gcc/testsuite/ada/acats/tests/c9/c95074c.ada
new file mode 100644
index 000000000..872a5928d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95074c.ada
@@ -0,0 +1,103 @@
+-- C95074C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT 'FIRST, 'LAST, 'LENGTH, AND 'RANGE, CAN BE APPLIED TO AN
+-- OUT PARAMETER OR OUT PARAMETER SUBCOMPONENT THAT DOES NOT HAVE AN
+-- ACCESS TYPE.
+
+-- JWC 6/25/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95074C IS
+
+BEGIN
+
+ TEST ("C95074C", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " &
+ "NON-ACCESS FORMAL OUT PARAMETERS");
+
+ DECLARE
+
+ TYPE ARR IS ARRAY (1 .. 10) OF NATURAL;
+
+ TYPE REC IS RECORD
+ A : ARR;
+ END RECORD;
+
+ A1 : ARR;
+ R1 : REC;
+
+ TASK T1 IS
+ ENTRY E (A2 : OUT ARR; R2 : OUT REC);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E (A2 : OUT ARR; R2 : OUT REC) DO
+
+ IF A2'FIRST /= 1 THEN
+ FAILED ("WRONG VALUE FOR A2'FIRST");
+ END IF;
+
+ IF A2'LAST /= 10 THEN
+ FAILED ("WRONG VALUE FOR A2'LAST");
+ END IF;
+
+ IF A2'LENGTH /= 10 THEN
+ FAILED ("WRONG VALUE FOR A2'LENGTH");
+ END IF;
+
+ IF (1 NOT IN A2'RANGE) OR
+ (10 NOT IN A2'RANGE) OR
+ (0 IN A2'RANGE) OR
+ (11 IN A2'RANGE) THEN
+ FAILED ("WRONG VALUE FOR A2'RANGE");
+ END IF;
+
+ IF R2.A'FIRST /= 1 THEN
+ FAILED ("WRONG VALUE FOR R2.A'FIRST");
+ END IF;
+
+ IF R2.A'LAST /= 10 THEN
+ FAILED ("WRONG VALUE FOR R2.A'LAST");
+ END IF;
+
+ IF R2.A'LENGTH /= 10 THEN
+ FAILED ("WRONG VALUE FOR R2.A'LENGTH");
+ END IF;
+
+ IF (1 NOT IN R2.A'RANGE) OR
+ (10 NOT IN R2.A'RANGE) OR
+ (0 IN R2.A'RANGE) OR
+ (11 IN R2.A'RANGE) THEN
+ FAILED ("WRONG VALUE FOR R2.A'RANGE");
+ END IF;
+ END E;
+ END T1;
+
+ BEGIN
+ T1.E (A1,R1);
+ END;
+
+ RESULT;
+END C95074C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95076a.ada b/gcc/testsuite/ada/acats/tests/c9/c95076a.ada
new file mode 100644
index 000000000..ba00cee68
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95076a.ada
@@ -0,0 +1,85 @@
+-- C95076A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT AN ACCEPT STATEMENT WITH AND WITHOUT A RETURN
+-- STATEMENT RETURNS CORRECTLY.
+
+-- GLH 7/11/85
+
+WITH REPORT; USE REPORT;
+
+PROCEDURE C95076A IS
+
+ I : INTEGER;
+
+ TASK T1 IS
+ ENTRY E1 (N : IN OUT INTEGER);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (N : IN OUT INTEGER) DO
+ IF (N = 5) THEN
+ N := N + 5;
+ ELSE
+ N := 0;
+ END IF;
+ END E1;
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (N : IN OUT INTEGER);
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (N : IN OUT INTEGER) DO
+ IF (N = 10) THEN
+ N := N + 5;
+ RETURN;
+ END IF;
+ N := 0;
+ END E2;
+ END T2;
+
+BEGIN
+
+ TEST ("C95076A", "CHECK THAT AN ACCEPT STATEMENT WITH AND " &
+ "WITHOUT A RETURN STATEMENT RETURNS CORRECTLY");
+
+ I := 5;
+ T1.E1 (I);
+ IF (I /= 10) THEN
+ FAILED ("INCORRECT RENDEVOUS WITHOUT A RETURN");
+ END IF;
+
+ I := 10;
+ T2.E2 (I);
+ IF (I /= 15) THEN
+ FAILED ("INCORRECT RENDEVOUS WITH A RETURN");
+ END IF;
+
+ RESULT;
+
+END C95076A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95078a.ada b/gcc/testsuite/ada/acats/tests/c9/c95078a.ada
new file mode 100644
index 000000000..399be9602
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95078a.ada
@@ -0,0 +1,195 @@
+-- C95078A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT AN EXCEPTION RAISED DURING THE EXECUTION OF AN ACCEPT
+-- STATEMENT CAN BE HANDLED WITHIN THE ACCEPT BODY.
+
+-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
+-- *** remove incompatibilities associated with the transition -- 9X
+-- *** to Ada 9X. -- 9X
+-- *** -- 9X
+
+-- HISTORY:
+-- DHH 03/21/88 CREATED ORIGINAL TEST.
+-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95078A IS
+
+BEGIN
+
+ TEST("C95078A", "CHECK THAT AN EXCEPTION RAISED DURING THE " &
+ "EXECUTION OF AN ACCEPT STATEMENT CAN BE " &
+ "HANDLED WITHIN THE ACCEPT BODY");
+
+ DECLARE
+ O,PT,QT,R,S,TP,B,C,D :INTEGER := 0;
+ TASK TYPE PROG_ERR IS
+ ENTRY START(M,N,A : IN OUT INTEGER);
+ ENTRY STOP;
+ END PROG_ERR;
+
+ TASK T IS
+ ENTRY START(M,N,A : IN OUT INTEGER);
+ ENTRY STOP;
+ END T;
+
+ TYPE REC IS
+ RECORD
+ B : PROG_ERR;
+ END RECORD;
+
+ TYPE ACC IS ACCESS PROG_ERR;
+
+ SUBTYPE X IS INTEGER RANGE 1 .. 10;
+
+ PACKAGE P IS
+ OBJ : REC;
+ END P;
+
+ TASK BODY PROG_ERR IS
+ FAULT : X;
+ BEGIN
+ ACCEPT START(M,N,A : IN OUT INTEGER) DO
+ BEGIN
+ M := IDENT_INT(1);
+ FAULT := IDENT_INT(11);
+ FAULT := IDENT_INT(FAULT);
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED ERROR RAISED - " &
+ "CONSTRAINT - TASK TYPE");
+ END; -- EXCEPTION
+ BEGIN
+ N := IDENT_INT(1);
+ FAULT := IDENT_INT(5);
+ FAULT := FAULT/IDENT_INT(0);
+ FAULT := IDENT_INT(FAULT);
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED ERROR RAISED - " &
+ "CONSTRAINT - TASK TYPE");
+ END; -- EXCEPTION
+ A := IDENT_INT(1);
+ END START;
+
+ ACCEPT STOP;
+ END PROG_ERR;
+
+ TASK BODY T IS
+ FAULT : X;
+ BEGIN
+ ACCEPT START(M,N,A : IN OUT INTEGER) DO
+ BEGIN
+ M := IDENT_INT(1);
+ FAULT := IDENT_INT(11);
+ FAULT := IDENT_INT(FAULT);
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED ERROR RAISED - " &
+ "CONSTRAINT - TASK");
+ END; -- EXCEPTION
+ BEGIN
+ N := IDENT_INT(1);
+ FAULT := IDENT_INT(5);
+ FAULT := FAULT/IDENT_INT(0);
+ FAULT := IDENT_INT(FAULT);
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED ERROR RAISED - " &
+ "CONSTRAINT - TASK");
+ END; -- EXCEPTION
+ A := IDENT_INT(1);
+ END START;
+
+ ACCEPT STOP;
+ END T;
+
+ PACKAGE BODY P IS
+ BEGIN
+ OBJ.B.START(O,PT,B);
+ OBJ.B.STOP;
+
+ IF O /= IDENT_INT(1) OR PT /= IDENT_INT(1) THEN
+ FAILED("EXCEPTION HANDLER NEVER ENTERED " &
+ "PROPERLY - TASK TYPE OBJECT");
+ END IF;
+
+ IF B /= IDENT_INT(1) THEN
+ FAILED("TASK NOT EXITED PROPERLY - TASK TYPE " &
+ "OBJECT");
+ END IF;
+ END P;
+
+ PACKAGE Q IS
+ OBJ : ACC;
+ END Q;
+
+ PACKAGE BODY Q IS
+ BEGIN
+ OBJ := NEW PROG_ERR;
+ OBJ.START(QT,R,C);
+ OBJ.STOP;
+
+ IF QT /= IDENT_INT(1) OR R /= IDENT_INT(1) THEN
+ FAILED("EXCEPTION HANDLER NEVER ENTERED " &
+ "PROPERLY - ACCESS TASK TYPE");
+ END IF;
+
+ IF C /= IDENT_INT(1) THEN
+ FAILED("TASK NOT EXITED PROPERLY - ACCESS TASK " &
+ "TYPE");
+ END IF;
+ END;
+
+ BEGIN
+ T.START(S,TP,D);
+ T.STOP;
+
+ IF S /= IDENT_INT(1) OR TP /= IDENT_INT(1) THEN
+ FAILED("EXCEPTION HANDLER NEVER ENTERED PROPERLY " &
+ "- TASK");
+ END IF;
+
+ IF D /= IDENT_INT(1) THEN
+ FAILED("TASK NOT EXITED PROPERLY - TASK");
+ END IF;
+ END; -- DECLARE
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED("EXCEPTION NOT HANDLED INSIDE ACCEPT BODY");
+ RESULT;
+END C95078A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95080b.ada b/gcc/testsuite/ada/acats/tests/c9/c95080b.ada
new file mode 100644
index 000000000..1c3c3b8b0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95080b.ada
@@ -0,0 +1,71 @@
+-- C95080B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT PARAMETERLESS ENTRIES CAN BE CALLED WITH THE APPROPRIATE
+-- NOTATION.
+
+-- JWC 7/15/85
+-- JRK 8/21/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95080B IS
+
+ I : INTEGER := 1;
+
+ TASK T IS
+ ENTRY E;
+ ENTRY EF (1..3);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E DO
+ I := 15;
+ END E;
+ ACCEPT EF (2) DO
+ I := 20;
+ END EF;
+ END T;
+
+BEGIN
+
+ TEST ("C95080B", "CHECK THAT PARAMETERLESS ENTRIES CAN BE " &
+ "CALLED");
+
+ T.E;
+ IF I /= 15 THEN
+ FAILED ("PARAMETERLESS ENTRY CALL YIELDS INCORRECT " &
+ "RESULT");
+ END IF;
+
+ I := 0;
+ T.EF (2);
+ IF I /= 20 THEN
+ FAILED ("PARAMETERLESS ENTRY FAMILY CALL YIELDS " &
+ "INCORRECT RESULT");
+ END IF;
+
+ RESULT;
+
+END C95080B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95082g.ada b/gcc/testsuite/ada/acats/tests/c9/c95082g.ada
new file mode 100644
index 000000000..f02e35db0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95082g.ada
@@ -0,0 +1,91 @@
+-- C95082G.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT FOR CALLS TO ENTRIES HAVING AT LEAST ONE DEFAULT
+-- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND
+-- FORMAL PARAMETERS.
+
+-- JWC 7/17/85
+
+WITH REPORT;USE REPORT;
+PROCEDURE C95082G IS
+
+ Y1,Y2,Y3 : INTEGER := 0;
+
+ TASK T IS
+ ENTRY E (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3;
+ O1,O2,O3: OUT INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E (I1: INTEGER; I2: INTEGER := 2;
+ I3: INTEGER := 3;
+ O1,O2,O3: OUT INTEGER) DO
+ O1 := I1;
+ O2 := I2;
+ O3 := I3;
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+
+BEGIN
+
+ TEST ("C95082G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL " &
+ "PARAMETERS (HAVING DEFAULT VALUES)");
+
+ T.E (I1=>11, I2=>12, I3=>13, O1=>Y1, O2=>Y2, O3=>Y3);
+ IF (Y1 /= 11) OR (Y2 /= 12) OR (Y3 /= 13) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 1");
+ END IF;
+
+ T.E (I1=>21, O1=>Y1, O2=>Y2, O3=>Y3);
+ IF (Y1 /= 21) OR (Y2 /= 2) OR (Y3 /= 3) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 2");
+ END IF;
+
+ T.E (O1=>Y1, O3=>Y3, I1=>31, I3=>33, O2=>Y2);
+ IF (Y1 /= 31) OR (Y2 /= 2) OR (Y3 /= 33) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 3");
+ END IF;
+
+ T.E (41, 42, O1=>Y1, O2=>Y2, O3=>Y3);
+ IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 4");
+ END IF;
+
+ T.E (51, O3=>Y3, O1=>Y1, O2=>Y2, I3=>53);
+ IF (Y1 /= 51) OR (Y2 /= 2) OR (Y3 /= 53) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 5");
+ END IF;
+
+ RESULT;
+
+END C95082G;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085a.ada b/gcc/testsuite/ada/acats/tests/c9/c95085a.ada
new file mode 100644
index 000000000..fc7e0dc9e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085a.ada
@@ -0,0 +1,279 @@
+-- C95085A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR
+-- ARGUMENTS. SUBTESTS ARE:
+-- (A) STATIC IN ARGUMENT.
+-- (B) DYNAMIC IN ARGUMENT.
+-- (C) IN OUT, OUT OF RANGE ON CALL.
+-- (D) OUT, OUT OF RANGE ON RETURN.
+-- (E) IN OUT, OUT OF RANGE ON RETURN.
+
+-- GLH 7/15/85
+-- JRK 8/23/85
+-- JWC 11/15/85 ADDED VARIABLE "CALLED" TO ENSURE THAT THE ENTRY
+-- CALL WAS MADE FOR THOSE CASES THAT ARE APPLICABLE.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085A IS
+
+ SUBTYPE DIGIT IS INTEGER RANGE 0..9;
+
+ D : DIGIT;
+ I : INTEGER;
+ M1 : CONSTANT INTEGER := IDENT_INT (-1);
+ COUNT : INTEGER := 0;
+ CALLED : BOOLEAN;
+
+ SUBTYPE SI IS INTEGER RANGE M1 .. 10;
+
+ TASK T1 IS
+ ENTRY E1 (PIN : IN DIGIT; WHO : STRING); -- (A), (B).
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ LOOP
+ BEGIN
+ SELECT
+ ACCEPT E1 (PIN : IN DIGIT;
+ WHO : STRING) DO -- (A), (B).
+ FAILED ("EXCEPTION NOT RAISED BEFORE " &
+ "CALL - E1 " & WHO);
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN E1");
+ END;
+ END LOOP;
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (PINOUT : IN OUT DIGIT; WHO : STRING); -- (C).
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ LOOP
+ BEGIN
+ SELECT
+ ACCEPT E2 (PINOUT : IN OUT DIGIT;
+ WHO : STRING) DO -- (C).
+ FAILED ("EXCEPTION NOT RAISED BEFORE " &
+ "CALL - E2 " & WHO);
+ END E2;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN E2");
+ END;
+ END LOOP;
+ END T2;
+
+ TASK T3 IS
+ ENTRY E3 (POUT : OUT SI; WHO : STRING); -- (D).
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN
+ LOOP
+ BEGIN
+ SELECT
+ ACCEPT E3 (POUT : OUT SI;
+ WHO : STRING) DO -- (D).
+ CALLED := TRUE;
+ IF WHO = "10" THEN
+ POUT := IDENT_INT (10); -- 10 IS NOT
+ -- A DIGIT.
+ ELSE
+ POUT := -1;
+ END IF;
+ END E3;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN E3");
+ END;
+ END LOOP;
+ END T3;
+
+ TASK T4 IS
+ ENTRY E4 (PINOUT : IN OUT INTEGER; WHO : STRING); -- (E).
+ END T4;
+
+ TASK BODY T4 IS
+ BEGIN
+ LOOP
+ BEGIN
+ SELECT
+ ACCEPT E4 (PINOUT : IN OUT INTEGER;
+ WHO : STRING) DO -- (E).
+ CALLED := TRUE;
+ IF WHO = "10" THEN
+ PINOUT := 10; -- 10 IS NOT A DIGIT.
+ ELSE
+ PINOUT := IDENT_INT (-1);
+ END IF;
+ END E4;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN E4");
+ END;
+ END LOOP;
+ END T4;
+
+BEGIN
+
+ TEST ("C95085A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "FOR OUT OF RANGE SCALAR ARGUMENTS");
+
+ BEGIN -- (A)
+ T1.E1 (10, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E1 (10)");
+ END; -- (A)
+
+ BEGIN -- (B)
+ T1.E1 (IDENT_INT (-1), "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (" &
+ "IDENT_INT (-1))");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E1 (" &
+ "IDENT_INT (-1))");
+ END; -- (B)
+
+ BEGIN -- (C)
+ I := IDENT_INT (10);
+ T2.E2 (I, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E2 (10)");
+ END; -- (C)
+
+ BEGIN -- (C1)
+ I := IDENT_INT (-1);
+ T2.E2 (I, "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (-1)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E2 (-1)");
+ END; -- (C1)
+
+ BEGIN -- (D)
+ CALLED := FALSE;
+ D := IDENT_INT (1);
+ T3.E3 (D, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
+ "E3 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "E3 (10)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E3 (10)");
+ END; -- (D)
+
+ BEGIN -- (D1)
+ CALLED := FALSE;
+ D := IDENT_INT (1);
+ T3.E3 (D, "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
+ "E3 (-1)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "E3 (-1)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E3 (-1)");
+ END; -- (D1)
+
+ BEGIN -- (E)
+ CALLED := FALSE;
+ D := 9;
+ T4.E4 (D, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
+ "E4 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "E4 (10)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E4 (10)");
+ END; -- (E)
+
+ BEGIN -- (E1)
+ CALLED := FALSE;
+ D := 0;
+ T4.E4 (D, "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
+ "E4 (-1)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "E4 (-1)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR E4 (-1)");
+ END; -- (E1)
+
+ IF COUNT /= 8 THEN
+ FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED");
+ END IF;
+
+ RESULT;
+
+END C95085A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085b.ada b/gcc/testsuite/ada/acats/tests/c9/c95085b.ada
new file mode 100644
index 000000000..27ef17052
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085b.ada
@@ -0,0 +1,183 @@
+-- C95085B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER APPROPRIATE CIRCUMSTANCES
+-- WITH RESPECT TO PARAMETERS OF RECORD TYPES IN ENTRY CALLS. SUBTESTS
+-- INVOLVE ACTUAL RECORD PARAMETERS WHOSE CONSTRAINT VALUES ARE NOT
+-- EQUAL TO THE CONSTRAINTS ON THEIR CORRESPONDING FORMAL PARAMETERS:
+-- (A) IN PARAMETER, STATIC AGGREGATE.
+-- (B) IN PARAMETER, DYNAMIC AGGREGATE.
+-- (C) IN PARAMETER, VARIABLE.
+-- (D) IN OUT PARAMETER, EXCEPTION RAISED ON CALL.
+-- (E) OUT PARAMETER, EXCEPTION RAISED ON CALL.
+
+-- JWC 10/25/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085B IS
+
+ SUBTYPE INT IS INTEGER RANGE 0..10;
+
+ TYPE REC (N : INT := 0) IS
+ RECORD
+ A : STRING (1..N);
+ END RECORD;
+
+ SUBTYPE SREC IS REC(N=>3);
+
+BEGIN
+
+ TEST ("C95085B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " &
+ "PARAMETERS OF RECORD TYPES");
+
+ DECLARE
+
+ TASK TSK1 IS
+ ENTRY E (R : IN SREC);
+ END TSK1;
+
+ TASK BODY TSK1 IS
+ BEGIN
+ LOOP
+ BEGIN
+ SELECT
+ ACCEPT E (R : IN SREC) DO
+ FAILED ("EXCEPTION NOT RAISED ON " &
+ "CALL TO TSK1");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TSK1");
+ END;
+ END LOOP;
+ END TSK1;
+
+ BEGIN
+
+ BEGIN -- (A)
+ TSK1.E ((2,"AA"));
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (A)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (A)");
+ END; -- (A)
+
+ BEGIN -- (B)
+ TSK1.E ((IDENT_INT(2), "AA"));
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (B)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (B)");
+ END; -- (B)
+
+ DECLARE -- (C)
+ R : REC := (IDENT_INT(2), "AA");
+ BEGIN -- (C)
+ TSK1.E (R);
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)");
+ END; -- (C)
+
+ END;
+
+ DECLARE -- (D)
+
+ R : REC := (IDENT_INT(2), "AA");
+
+ TASK TSK2 IS
+ ENTRY E (R : IN OUT SREC);
+ END TSK2;
+
+ TASK BODY TSK2 IS
+ BEGIN
+ SELECT
+ ACCEPT E (R : IN OUT SREC) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL TO " &
+ "TSK2");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TSK2");
+ END TSK2;
+
+ BEGIN -- (D)
+ TSK2.E (R);
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (D)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (D)");
+ END; -- (D)
+
+ DECLARE -- (E)
+
+ R : REC;
+
+ TASK TSK3 IS
+ ENTRY E (R : OUT SREC);
+ END TSK3;
+
+ TASK BODY TSK3 IS
+ BEGIN
+ SELECT
+ ACCEPT E (R : OUT SREC) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL TO " &
+ "TSK3");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TSK3");
+ END TSK3;
+
+ BEGIN -- (E)
+ TSK3.E (R);
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (E)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (E)");
+ END; -- (E)
+
+ RESULT;
+
+END C95085B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085c.ada b/gcc/testsuite/ada/acats/tests/c9/c95085c.ada
new file mode 100644
index 000000000..f2875e340
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085c.ada
@@ -0,0 +1,245 @@
+-- C95085C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE
+-- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS IN ENTRY CALLS,
+-- NAMELY WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS
+-- (BEFORE THE CALL FOR ALL MODES).
+-- SUBTESTS ARE:
+-- (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE.
+-- (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE.
+-- (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE.
+-- (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE.
+-- (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE.
+-- (F) IN OUT MODE, NULL STRING AGGREGATE.
+-- (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE).
+-- IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE.
+
+-- JWC 10/28/85
+-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085C IS
+
+BEGIN
+ TEST ("C95085C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
+ "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+ SUBTYPE ST IS STRING (1..3);
+
+ TASK TSK IS
+ ENTRY E (A : ST);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (A : ST) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL - (A)");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (A)");
+ END TSK;
+
+ BEGIN -- (A)
+
+ TSK.E ("AB");
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (A)");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ SUBTYPE S IS INTEGER RANGE 1..3;
+ TYPE T IS ARRAY (S,S) OF INTEGER;
+
+ TASK TSK IS
+ ENTRY E (A : T);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (A : T) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL - (B)");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (B)");
+ END TSK;
+
+ BEGIN -- (B)
+
+ TSK.E ((1..3 => (1..IDENT_INT(2) => 0)));
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ SUBTYPE S IS INTEGER RANGE 1..5;
+ TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER;
+ SUBTYPE ST IS T (1..3,1..3);
+ V : T (1..IDENT_INT(2), 1..3) :=
+ (1..IDENT_INT(2) => (1..3 => 0));
+
+ TASK TSK IS
+ ENTRY E (A :ST);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (A :ST) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL - (C)");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (C)");
+ END TSK;
+
+ BEGIN -- (C)
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (C)");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ SUBTYPE S IS INTEGER RANGE 1..5;
+ TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF
+ INTEGER;
+ SUBTYPE ST IS T (1..3, 1..3, 1..3);
+ V : T (1..3, 1..2, 1..3) :=
+ (1..3 => (1..2 => (1..3 => 0)));
+
+ TASK TSK IS
+ ENTRY E (A : IN OUT ST);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (A : IN OUT ST) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL - (D)");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (D)");
+ END TSK;
+
+ BEGIN -- (D)
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (D)");
+ END; -- (D)
+
+ --------------------------------------------------
+
+
+ DECLARE -- (G)
+
+ SUBTYPE S IS INTEGER RANGE 1..5;
+ TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER;
+ SUBTYPE ST IS T (2..1, 2..1);
+ V : T (2..1, 2..1) := (2..1 => (2..1 => ' '));
+
+ TASK TSK IS
+ ENTRY E (A : IN OUT ST);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (A : IN OUT ST) DO
+ COMMENT ("OK CASE CALLED CORRECTLY");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (G)");
+ END TSK;
+
+ BEGIN -- (G)
+
+ TSK.E (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)");
+ END; -- (G)
+
+ --------------------------------------------------
+
+
+ RESULT;
+END C95085C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085d.ada b/gcc/testsuite/ada/acats/tests/c9/c95085d.ada
new file mode 100644
index 000000000..059298180
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085d.ada
@@ -0,0 +1,97 @@
+-- C95085D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (A) BEFORE CALL, IN MODE, STATIC PRIVATE DISCRIMINANT.
+
+-- JWC 10/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085D IS
+
+BEGIN
+ TEST ("C95085D", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2, E3);
+ TYPE T (D : E := E1) IS PRIVATE;
+ TYPE AR IS ARRAY (E1 .. E3) OF INTEGER;
+ PRIVATE
+ TYPE T (D : E := E1) IS
+ RECORD
+ I : INTEGER;
+ A : AR;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE A1 IS A (E3);
+ V : A (E2) := NEW T (E2);
+
+ TASK TSK IS
+ ENTRY E (X : A1);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : A1) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ ------------------------------------------------
+
+ RESULT;
+END C95085D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085e.ada b/gcc/testsuite/ada/acats/tests/c9/c95085e.ada
new file mode 100644
index 000000000..86c446c8b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085e.ada
@@ -0,0 +1,87 @@
+-- C95085E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (B) BEFORE CALL, IN MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
+
+-- JWC 10/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085E IS
+
+BEGIN
+ TEST ("C95085E", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ TYPE T IS ARRAY (BOOLEAN RANGE <>, CHARACTER RANGE <>) OF
+ INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE A1 IS A (BOOLEAN, 'A'..'C');
+ V : A := NEW T (BOOLEAN, 'A'..IDENT_CHAR('B'));
+
+ TASK TSK IS
+ ENTRY E (X : A1);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : A1) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085E;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085f.ada b/gcc/testsuite/ada/acats/tests/c9/c95085f.ada
new file mode 100644
index 000000000..7a716595d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085f.ada
@@ -0,0 +1,84 @@
+-- C95085F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY
+-- WHEN THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (C) BEFORE CALL, IN OUT MODE, STATIC ONE DIMENSIONAL BOUNDS.
+
+-- JWC 10/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085F IS
+
+BEGIN
+ TEST ("C95085F", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ TYPE A IS ACCESS STRING;
+ SUBTYPE A1 IS A (1..3);
+ V : A (2..4) := NEW STRING (2..4);
+
+ TASK TSK IS
+ ENTRY E (X : IN OUT A1);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : IN OUT A1) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085g.ada b/gcc/testsuite/ada/acats/tests/c9/c95085g.ada
new file mode 100644
index 000000000..2004164d2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085g.ada
@@ -0,0 +1,98 @@
+-- C95085G.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (D) BEFORE CALL, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
+
+-- JWC 10/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085G IS
+
+BEGIN
+ TEST ("C95085G", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ SUBTYPE INT IS INTEGER RANGE 0..10;
+ TYPE T (C : CHARACTER := 'A';
+ B : BOOLEAN := FALSE;
+ I : INT := 0) IS
+ RECORD
+ J : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ K : INTEGER;
+ WHEN TRUE =>
+ S : STRING (1 .. I);
+ END CASE;
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A ('Z', TRUE, 5);
+ V : A := NEW T ('Z', IDENT_BOOL(FALSE), 5);
+
+ TASK TSK IS
+ ENTRY E (X : IN OUT SA);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : IN OUT SA) DO
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085G;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085h.ada b/gcc/testsuite/ada/acats/tests/c9/c95085h.ada
new file mode 100644
index 000000000..a46720474
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085h.ada
@@ -0,0 +1,111 @@
+-- C95085H.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (E) AFTER RETURN, IN OUT MODE, STATIC LIMITED PRIVATE
+-- DISCRIMINANTS.
+
+-- JWC 10/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085H IS
+
+BEGIN
+ TEST ("C95085H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ PACKAGE PKG IS
+ SUBTYPE INT IS INTEGER RANGE 0..10;
+ SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'C';
+ TYPE T (I : INT := 0; C : CHAR := 'A') IS
+ LIMITED PRIVATE;
+ PRIVATE
+ TYPE T (I : INT := 0; C : CHAR := 'A') IS
+ RECORD
+ J : INTEGER;
+ CASE C IS
+ WHEN 'A' =>
+ K : INTEGER;
+ WHEN 'B' =>
+ S : STRING (1..I);
+ WHEN OTHERS =>
+ NULL;
+ END CASE;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+
+ V : A (2,'B') := NEW T (2,'B');
+
+ TASK TSK IS
+ ENTRY E (X : IN OUT A);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : IN OUT A) DO
+ CALLED := TRUE;
+ X := NEW T (2,'A');
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085H;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085i.ada b/gcc/testsuite/ada/acats/tests/c9/c95085i.ada
new file mode 100644
index 000000000..b2b08543c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085i.ada
@@ -0,0 +1,100 @@
+-- C95085I.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (F) AFTER RETURN, IN OUT MODE, DYNAMIC THREE DIMENSIONAL
+-- BOUNDS.
+
+-- JWC 10/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085I IS
+
+BEGIN
+ TEST ("C95085I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ TYPE E IS (E1, E2, E3);
+
+ TYPE T IS ARRAY (CHARACTER RANGE <>,
+ E RANGE <>,
+ BOOLEAN RANGE <>
+ ) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+
+ V : A ('A'..'Z', E1..E2, BOOLEAN) :=
+ NEW T ('A'..'Z', E1..E2, BOOLEAN);
+
+ TASK TSK IS
+ ENTRY E (X : IN OUT A);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : IN OUT A) DO
+ CALLED := TRUE;
+ IF EQUAL (3,3) THEN
+ X := NEW T ('A'..'Z', E2..E3, BOOLEAN);
+ END IF;
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085I;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085j.ada b/gcc/testsuite/ada/acats/tests/c9/c95085j.ada
new file mode 100644
index 000000000..d1ea3ce2e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085j.ada
@@ -0,0 +1,90 @@
+-- C95085J.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (G) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, STATIC ONE
+-- DIMENSIONAL BOUNDS.
+
+-- JWC 10/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085J IS
+
+BEGIN
+ TEST ("C95085J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ TYPE A IS ACCESS STRING;
+
+ V : A (1..3) := NEW STRING (1..3);
+
+ TASK TSK IS
+ ENTRY E (X : OUT A);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : OUT A) DO
+ CALLED := TRUE;
+ X := NEW STRING (2..3);
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085J;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085k.ada b/gcc/testsuite/ada/acats/tests/c9/c95085k.ada
new file mode 100644
index 000000000..37952f0ae
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085k.ada
@@ -0,0 +1,97 @@
+-- C95085K.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (H) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, DYNAMIC
+-- RECORD DISCRIMINANT.
+
+-- JWC 10/24/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085K IS
+
+BEGIN
+ TEST ("C95085K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ TYPE ARR IS ARRAY (BOOLEAN RANGE <>) OF INTEGER;
+ TYPE T (B : BOOLEAN := FALSE) IS
+ RECORD
+ I : INTEGER;
+ A : ARR (FALSE..B);
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+
+ V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE));
+
+ TASK TSK IS
+ ENTRY E (X : OUT A);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : OUT A) DO
+ CALLED := TRUE;
+ X := NEW T (TRUE);
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085K;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085l.ada b/gcc/testsuite/ada/acats/tests/c9/c95085l.ada
new file mode 100644
index 000000000..cb62ff249
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085l.ada
@@ -0,0 +1,109 @@
+-- C95085L.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN
+-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (I) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, STATIC
+-- PRIVATE DISCRIMINANTS.
+
+-- JWC 10/24/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085L IS
+
+BEGIN
+ TEST ("C95085L", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2, E3);
+ TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS
+ PRIVATE;
+ PRIVATE
+ TYPE ARR IS ARRAY (E RANGE <>) OF INTEGER;
+ TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS
+ RECORD
+ I : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ J : INTEGER;
+ WHEN TRUE =>
+ A : ARR (E1 .. D);
+ END CASE;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (E2, TRUE);
+ V : A (E2, FALSE) := NEW T (E2, FALSE);
+
+ TASK TSK IS
+ ENTRY E (X : OUT SA);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : OUT SA) DO
+ CALLED := TRUE;
+ X := NEW T (E2, TRUE);
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ ------------------------------------------------
+
+ RESULT;
+END C95085L;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085m.ada b/gcc/testsuite/ada/acats/tests/c9/c95085m.ada
new file mode 100644
index 000000000..45e73fffa
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085m.ada
@@ -0,0 +1,96 @@
+-- C95085M.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (J) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, DYNAMIC TWO
+-- DIMENSIONAL BOUNDS.
+
+-- JWC 10/24/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085M IS
+
+BEGIN
+ TEST ("C95085M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ TYPE T IS ARRAY (INTEGER RANGE <>,
+ CHARACTER RANGE <>) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+
+ V : A (1..10, 'A'..'Z') := NEW T (1..10, 'A'..'Z');
+
+ Y : CONSTANT CHARACTER := IDENT_CHAR('Y');
+ SUBTYPE SA IS A (1..10, 'A'..Y);
+
+ TASK TSK IS
+ ENTRY E (X : OUT SA);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : OUT SA) DO
+ CALLED := TRUE;
+ X := NEW T (1..10, 'A'..IDENT_CHAR('Y'));
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ BEGIN
+
+ TSK.E (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95085M;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085n.ada b/gcc/testsuite/ada/acats/tests/c9/c95085n.ada
new file mode 100644
index 000000000..7f7e3a63b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085n.ada
@@ -0,0 +1,117 @@
+-- C95085N.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE
+-- CASE OF A PRIVATE TYPE IMPLEMENTED AS A SCALAR TYPE WHERE THE VALUE
+-- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL
+-- PARAMETER.
+
+-- JWC 10/29/85
+-- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE
+-- CALL.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085N IS
+
+BEGIN
+ TEST ("C95085N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " &
+ "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " &
+ "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE");
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ PACKAGE P IS
+ TYPE T IS PRIVATE;
+ DC : CONSTANT T;
+
+ GENERIC PACKAGE PP IS
+ END PP;
+ PRIVATE
+ TYPE T IS NEW INTEGER;
+ DC : CONSTANT T := -1;
+ END P;
+
+ TASK TSK IS
+ ENTRY E (X : OUT P.T);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : OUT P.T) DO
+ CALLED := TRUE;
+ X := P.DC;
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ GENERIC
+ Y : IN OUT P.T;
+ PACKAGE CALL IS
+ END CALL;
+
+ PACKAGE BODY CALL IS
+ BEGIN
+ TSK.E (Y);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END CALL;
+
+ PACKAGE BODY P IS
+ Z : T RANGE 0..1 := 0;
+ PACKAGE BODY PP IS
+ PACKAGE CALL_Q IS NEW CALL (Z);
+ END PP;
+ END P;
+
+ BEGIN
+
+ BEGIN
+ DECLARE
+ PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE.
+ BEGIN
+ NULL;
+ END;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("WRONG HANDLER INVOKED");
+ END;
+
+ END;
+
+ RESULT;
+END C95085N;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085o.ada b/gcc/testsuite/ada/acats/tests/c9/c95085o.ada
new file mode 100644
index 000000000..f5cd288a3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95085o.ada
@@ -0,0 +1,118 @@
+-- C95085O.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE
+-- CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE THE VALUE
+-- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL
+-- PARAMETER.
+
+-- JWC 10/30/85
+-- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE
+-- CALL.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95085O IS
+
+BEGIN
+
+ TEST ("C95085O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " &
+ "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " &
+ "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE");
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ PACKAGE P IS
+ TYPE T IS PRIVATE;
+ DC : CONSTANT T;
+
+ GENERIC PACKAGE PP IS
+ END PP;
+ PRIVATE
+ TYPE T IS ACCESS STRING;
+ DC : CONSTANT T := NEW STRING'("AAA");
+ END P;
+
+ TASK TSK IS
+ ENTRY E (X : IN OUT P.T);
+ END TSK;
+
+ TASK BODY TSK IS
+ BEGIN
+ SELECT
+ ACCEPT E (X : IN OUT P.T) DO
+ CALLED := TRUE;
+ X := P.DC;
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK BODY");
+ END TSK;
+
+ GENERIC
+ Y : IN OUT P.T;
+ PACKAGE CALL IS
+ END CALL;
+
+ PACKAGE BODY CALL IS
+ BEGIN
+ TSK.E (Y);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END CALL;
+
+ PACKAGE BODY P IS
+ Z : T (1..5) := NEW STRING'("CCCCC");
+ PACKAGE BODY PP IS
+ PACKAGE CALL_Q IS NEW CALL (Z);
+ END PP;
+ END P;
+
+ BEGIN
+
+ BEGIN
+ DECLARE
+ PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE.
+ BEGIN
+ NULL;
+ END;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("WRONG HANDLER INVOKED");
+ END;
+
+ END;
+
+ RESULT;
+END C95085O;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086a.ada b/gcc/testsuite/ada/acats/tests/c9/c95086a.ada
new file mode 100644
index 000000000..e26e8b872
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95086a.ada
@@ -0,0 +1,94 @@
+-- C95086A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED AT THE TIME OF CALL WHEN
+-- THE VALUE OF AN ACTUAL OUT SCALAR PARAMETER DOES NOT SATISFY THE
+-- RANGE CONSTRAINTS OF THE FORMAL PARAMETER.
+
+-- GLH 7/16/85
+-- JRK 8/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95086A IS
+
+ SUBTYPE SUBINT1 IS INTEGER RANGE -10..10;
+ SUBTYPE SUBINT2 IS INTEGER RANGE -20..20;
+
+ I10 : SUBINT1 := 10;
+ I20 : SUBINT2 := 20;
+
+ TASK T1 IS
+ ENTRY E1 (I : OUT SUBINT1);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ LOOP
+ BEGIN
+ SELECT
+ ACCEPT E1 (I : OUT SUBINT1) DO
+ I := SUBINT1'FIRST;
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN ACCEPT E1");
+ END;
+ END LOOP;
+ END T1;
+
+BEGIN
+
+ TEST ("C95086A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "AT THE TIME OF CALL WHEN THE VALUE OF AN " &
+ "ACTUAL OUT SCALAR PARAMETER DOES NOT " &
+ "SATISFY THE RANGE CONSTRAINTS OF THE FORMAL " &
+ "PARAMETER");
+
+ BEGIN
+ T1.E1 (SUBINT1(I20));
+ IF I20 /= IDENT_INT (-10) THEN
+ FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 1");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED ON CALL TO E1 - 1");
+ END;
+
+ BEGIN
+ I20 := IDENT_INT (20);
+ T1.E1 (I20);
+ IF I20 /= IDENT_INT (-10) THEN
+ FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED ON CALL TO E1 - 2");
+ END;
+
+ RESULT;
+
+END C95086A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086b.ada b/gcc/testsuite/ada/acats/tests/c9/c95086b.ada
new file mode 100644
index 000000000..bc222ebc3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95086b.ada
@@ -0,0 +1,202 @@
+-- C95086B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
+-- BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS
+-- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT
+-- FROM THE FORMAL PARAMETER.
+--
+-- SUBTESTS ARE:
+-- (A) IN MODE, STATIC ONE DIMENSIONAL BOUNDS.
+-- (B) IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
+-- (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
+-- (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
+
+-- RJW 1/27/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95086B IS
+
+BEGIN
+ TEST ( "C95086B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL " &
+ "ACCESS PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS " &
+ "DIFFERENT FROM THE FORMAL PARAMETER" );
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE E IS (E1, E2, E3, E4);
+ TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (E2..E4);
+ V : A (E1..E2) := NULL;
+
+ TASK T1 IS
+ ENTRY P (X : SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : SA);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED IN TASK - (A)" );
+ END T1;
+
+ BEGIN -- (A)
+
+ T1.P (V);
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - (A)" );
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
+
+ TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
+ RECORD
+ I : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ J : INTEGER;
+ WHEN TRUE =>
+ A : ARR ('A' .. C);
+ END CASE;
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (TRUE, 'C');
+ V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
+
+ TASK T1 IS
+ ENTRY P (X : IN OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : IN OUT SA) DO
+ NULL;
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED IN TASK - (B)" );
+ END T1;
+
+ BEGIN -- (B)
+
+ T1.P (V);
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - (B)" );
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ TYPE E IS (E1, E2, E3, E4);
+ TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (E2..E4);
+ V : A (E1..E2) := NULL;
+
+ TASK T1 IS
+ ENTRY P (X : SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : SA) DO
+ NULL;
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED IN TASK - (C)" );
+ END T1;
+
+ BEGIN -- (C)
+
+ T1.P (SA(V));
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - (C)" );
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
+
+ TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
+ RECORD
+ I : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ J : INTEGER;
+ WHEN TRUE =>
+ A : ARR ('A' .. C);
+ END CASE;
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (TRUE, 'C');
+ V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
+
+ TASK T1 IS
+ ENTRY P (X : IN OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : IN OUT SA);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED IN TASK - (D)" );
+ END T1;
+
+ BEGIN -- (D)
+
+ T1.P (SA(V));
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - (D)" );
+ END; -- (D)
+
+ --------------------------------------------------
+
+ RESULT;
+END C95086B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086c.ada b/gcc/testsuite/ada/acats/tests/c9/c95086c.ada
new file mode 100644
index 000000000..9c2050b71
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95086c.ada
@@ -0,0 +1,250 @@
+-- C95086C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
+-- AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL
+-- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS
+-- DIFFERENT CONSTRAINTS.
+--
+-- SUBTESTS ARE:
+-- (A) IN OUT MODE, STATIC PRIVATE DISCRIMINANT.
+-- (B) OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
+-- (C) SAME AS (A), WITH TYPE CONVERSION.
+-- (D) SAME AS (B), WITH TYPE CONVERSION.
+
+-- RJW 1/29/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95086C IS
+
+BEGIN
+ TEST ("C95086C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL " &
+ "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " &
+ "DIFFERENT CONSTRAINTS" );
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2);
+ TYPE T (D : E := E1) IS PRIVATE;
+ PRIVATE
+ TYPE T (D : E := E1) IS
+ RECORD
+ I : INTEGER;
+ CASE D IS
+ WHEN E1 =>
+ B : BOOLEAN;
+ WHEN E2 =>
+ C : CHARACTER;
+ END CASE;
+ END RECORD;
+ END PKG;
+
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (E2);
+ V : A (E1) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ TASK T1 IS
+ ENTRY P (X : IN OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : IN OUT SA) DO
+ ENTERED := TRUE;
+ X := NULL;
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (A)");
+ END T1;
+
+ BEGIN -- (A)
+
+ T1.P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (A)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (A)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (A)");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
+ INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
+ V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
+ IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ TASK T1 IS
+ ENTRY P (X : OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : OUT SA) DO
+ ENTERED := TRUE;
+ X := NULL;
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (B)");
+ END T1;
+
+ BEGIN -- (B)
+
+ T1.P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (B)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (B)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (B)");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2);
+ TYPE T (D : E := E1) IS PRIVATE;
+ PRIVATE
+ TYPE T (D : E := E1) IS
+ RECORD
+ I : INTEGER;
+ CASE D IS
+ WHEN E1 =>
+ B : BOOLEAN;
+ WHEN E2 =>
+ C : CHARACTER;
+ END CASE;
+ END RECORD;
+ END PKG;
+
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (E2);
+ V : A (E1) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ TASK T1 IS
+ ENTRY P (X : IN OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : IN OUT SA) DO
+ ENTERED := TRUE;
+ X := NULL;
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (C)");
+ END T1;
+
+ BEGIN -- (C)
+
+ T1.P (SA(V));
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (C)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (C)");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
+ INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
+ V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
+ IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ TASK T1 IS
+ ENTRY P (X : OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : OUT SA) DO
+ ENTERED := TRUE;
+ X := NULL;
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (D)");
+ END T1;
+
+ BEGIN -- (D)
+
+ T1.P (SA(V));
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (D)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (D)");
+ END; -- (D)
+
+ --------------------------------------------------
+
+ RESULT;
+END C95086C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086d.ada b/gcc/testsuite/ada/acats/tests/c9/c95086d.ada
new file mode 100644
index 000000000..616c025fb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95086d.ada
@@ -0,0 +1,142 @@
+-- C95086D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
+-- BEFORE OR AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED ACTUAL
+-- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE
+-- ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL
+-- PARAMETER.
+--
+-- SUBTESTS ARE:
+-- (A) STATIC LIMITED PRIVATE DISCRIMINANT.
+-- (B) DYNAMIC ONE DIMENSIONAL BOUNDS.
+
+-- RJW 2/3/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95086D IS
+
+BEGIN
+ TEST ("C95086D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "BEFORE AND AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED " &
+ "ACTUAL OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR " &
+ "TO THE ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE " &
+ "FORMAL PARAMETER");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+ SUBTYPE INT IS INTEGER RANGE 0..5;
+ TYPE T (I : INT := 0) IS LIMITED PRIVATE;
+ PRIVATE
+ TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
+ TYPE T (I : INT := 0) IS
+ RECORD
+ J : INTEGER;
+ A : ARR (1..I);
+ END RECORD;
+ END PKG;
+
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A (3);
+ V : A := NEW T (2);
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T1 IS
+ ENTRY P (X : OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : OUT SA) DO
+ CALLED := TRUE;
+ X := NEW T (3);
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (A)");
+ END T1;
+
+ BEGIN -- (A)
+
+ T1.P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (A)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (A)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (A)");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ TYPE A IS ACCESS STRING;
+ SUBTYPE SA IS A (1..2);
+ V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7));
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T1 IS
+ ENTRY P (X : OUT SA);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT P (X : OUT SA) DO
+ CALLED := TRUE;
+ X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2));
+ END P;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (B)");
+ END T1;
+
+ BEGIN -- (B)
+
+ T1.P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (B)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (B)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (B)");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ RESULT;
+END C95086D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086e.ada b/gcc/testsuite/ada/acats/tests/c9/c95086e.ada
new file mode 100644
index 000000000..4e4f42b95
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95086e.ada
@@ -0,0 +1,282 @@
+-- C95086E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY
+-- CALL FOR IN OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE
+-- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED:
+-- (A) OK CASE.
+-- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER
+-- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE
+-- FORMAL INDEX SUBTYPE.
+-- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER
+-- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL
+-- ARRAYS.
+-- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE
+-- FORMAL INDEX SUBTYPE.
+-- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE
+-- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY.
+
+-- RJW 2/3/86
+-- TMB 11/15/95 ELIMINATED INCOMPATIBILITY WITH ADA95
+-- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95086E IS
+
+BEGIN
+ TEST ("C95086E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "BEFORE OR AFTER THE ENTRY CALL FOR IN OUT ARRAY " &
+ "PARAMETERS, WITH THE ACTUAL HAVING THE FORM OF A TYPE " &
+ "CONVERSION");
+
+ ---------------------------------------------
+
+ DECLARE -- (A)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..5;
+ TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
+ OF BOOLEAN;
+ SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3);
+ SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3);
+ AR : ACTUAL := (1..3 => (1..3 => TRUE));
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : IN OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : IN OUT FORMAL) DO
+ CALLED := TRUE;
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (A)");
+ END T;
+
+ BEGIN -- (A)
+
+ T.E (FORMAL (AR));
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (A)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (A)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (A)");
+ END; -- (A)
+
+ ---------------------------------------------
+
+ DECLARE -- (B)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..3;
+ TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN;
+ TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN;
+ AR : ACTUAL := (3..5 => (3..5 => FALSE));
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : IN OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : IN OUT FORMAL) DO
+ CALLED := TRUE;
+ X(3, 3) := TRUE;
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (B)");
+ END T;
+
+ BEGIN -- (B)
+
+ T.E (FORMAL (AR));
+ IF AR(5, 5) /= TRUE THEN
+ FAILED ("INCORRECT RETURNED VALUE - (B)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (B)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (B)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (B)");
+ END; -- (B)
+
+ ---------------------------------------------
+
+ DECLARE -- (C)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..5;
+ TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
+ OF CHARACTER;
+ SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3);
+ AR : ARRAY_TYPE (2..1, 1..3) := (2..1 => (1..3 => ' '));
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : IN OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : IN OUT FORMAL) DO
+ IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN
+ FAILED ("WRONG BOUNDS PASSED - (C)");
+ END IF;
+ CALLED := TRUE;
+ X := (2..0 => (1..3 => 'A'));
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (C)");
+ END T;
+
+ BEGIN -- (C)
+
+ T.E (FORMAL (AR));
+ IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN
+ FAILED ("BOUNDS CHANGED - (C)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (C)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (C)");
+ END; -- (C)
+
+ ---------------------------------------------
+
+ DECLARE -- (D)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..3;
+ TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1)
+ OF CHARACTER;
+ TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER;
+ AR : ACTUAL := (3..5 => (5..3 => ' '));
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : IN OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : IN OUT FORMAL) DO
+ IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN
+ FAILED ("WRONG BOUNDS PASSED - (D)");
+ END IF;
+ CALLED := TRUE;
+ X := (1..3 => (3..1 => 'A'));
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (D)");
+ END T;
+
+ BEGIN -- (D)
+
+ T.E (FORMAL (AR));
+ IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN
+ FAILED ("BOUNDS CHANGED - (D)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (D)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (D)");
+ END; -- (D)
+
+ ---------------------------------------------
+
+ DECLARE -- (E)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..3;
+ TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
+ OF CHARACTER;
+ TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2,
+ POSITIVE RANGE 1..3) OF CHARACTER;
+ AR : ACTUAL := (5..2 => (1..3 => ' '));
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : IN OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : IN OUT FORMAL) DO
+ IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN
+ FAILED ("WRONG BOUNDS PASSED - (E)");
+ END IF;
+ CALLED := TRUE;
+ X := (3..1 => (1..3 => ' '));
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (E)");
+ END T;
+
+ BEGIN -- (E)
+
+ T.E (FORMAL (AR));
+ IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN
+ FAILED ("BOUNDS CHANGED - (E)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (E)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (E)");
+ END; -- (E)
+
+ ---------------------------------------------
+
+ RESULT;
+END C95086E;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086f.ada b/gcc/testsuite/ada/acats/tests/c9/c95086f.ada
new file mode 100644
index 000000000..00b84441b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95086f.ada
@@ -0,0 +1,282 @@
+-- C95086F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY
+-- CALL FOR OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE
+-- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED:
+-- (A) OK CASE.
+-- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER
+-- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE
+-- FORMAL INDEX SUBTYPE.
+-- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER
+-- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL
+-- ARRAYS.
+-- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE
+-- FORMAL INDEX SUBTYPE.
+-- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE
+-- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY.
+
+-- RJW 2/3/86
+-- TMB 11/15/95 FIXED INCOMPATIBILITIES WITH ADA95
+-- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95086F IS
+
+BEGIN
+ TEST ("C95086F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "BEFORE OR AFTER THE ENTRY CALL FOR OUT ARRAY PARAMETERS, " &
+ "WITH THE ACTUAL HAVING THE FORM OF A TYPE CONVERSION");
+
+ ---------------------------------------------
+
+ DECLARE -- (A)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..5;
+ TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
+ OF BOOLEAN;
+ SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3);
+ SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3);
+ AR : ACTUAL;
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : OUT FORMAL) DO
+ CALLED := TRUE;
+ X := (1..3 => (1..3 => TRUE));
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (A)");
+ END T;
+
+ BEGIN -- (A)
+
+ T.E (FORMAL (AR));
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (A)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (A)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (A)");
+ END; -- (A)
+
+ ---------------------------------------------
+
+ DECLARE -- (B)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..3;
+ TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN;
+ TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN;
+ AR : ACTUAL;
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : OUT FORMAL) DO
+ CALLED := TRUE;
+ X(3, 3) := TRUE;
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (B)");
+ END T;
+
+ BEGIN -- (B)
+
+ T.E (FORMAL (AR));
+ IF AR(5, 5) /= TRUE THEN
+ FAILED ("INCORRECT RETURNED VALUE - (B)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (B)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (B)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (B)");
+ END; -- (B)
+
+ ---------------------------------------------
+
+ DECLARE -- (C)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..5;
+ TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
+ OF CHARACTER;
+ SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3);
+ AR : ARRAY_TYPE (2..1, 1..3);
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : OUT FORMAL) DO
+ IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN
+ FAILED ("WRONG BOUNDS PASSED - (C)");
+ END IF;
+ CALLED := TRUE;
+ X := (2..0 => (1..3 => 'A'));
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (C)");
+ END T;
+
+ BEGIN -- (C)
+
+ T.E (FORMAL (AR));
+ IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN
+ FAILED ("BOUNDS CHANGED - (C)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (C)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (C)");
+ END; -- (C)
+
+ ---------------------------------------------
+
+ DECLARE -- (D)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..3;
+ TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1)
+ OF CHARACTER;
+ TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER;
+ AR : ACTUAL;
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : OUT FORMAL) DO
+ IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN
+ FAILED ("WRONG BOUNDS PASSED - (D)");
+ END IF;
+ CALLED := TRUE;
+ X := (1..3 => (3..1 => 'A'));
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (D)");
+ END T;
+
+ BEGIN -- (D)
+
+ T.E (FORMAL (AR));
+ IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN
+ FAILED ("BOUNDS CHANGED - (D)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (D)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (D)");
+ END; -- (D)
+
+ ---------------------------------------------
+
+ DECLARE -- (E)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..3;
+ TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>)
+ OF CHARACTER;
+ TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2,
+ POSITIVE RANGE 1..3) OF CHARACTER;
+ AR : ACTUAL;
+ CALLED : BOOLEAN := FALSE;
+
+ TASK T IS
+ ENTRY E (X : OUT FORMAL);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : OUT FORMAL) DO
+ IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN
+ FAILED ("WRONG BOUNDS PASSED - (E)");
+ END IF;
+ CALLED := TRUE;
+ X := (3..1 => (1..3 => ' ' ));
+ END E;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TASK - (E)");
+ END T;
+
+ BEGIN -- (E)
+
+ T.E (FORMAL (AR));
+ IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN
+ FAILED ("BOUNDS CHANGED - (E)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (E)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (E)");
+ END; -- (E)
+
+ ---------------------------------------------
+
+ RESULT;
+END C95086F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087a.ada b/gcc/testsuite/ada/acats/tests/c9/c95087a.ada
new file mode 100644
index 000000000..535cea40d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95087a.ada
@@ -0,0 +1,412 @@
+-- C95087A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY
+-- FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS.
+-- SUBTESTS ARE:
+-- (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS.
+-- (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS.
+-- (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS.
+-- (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS.
+
+-- GLH 7/19/85
+-- JRK 8/23/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95087A IS
+
+BEGIN
+ TEST ("C95087A", "CHECK USE OF ACTUAL CONSTRAINTS BY " &
+ "UNCONSTRAINED FORMAL PARAMETERS");
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INT IS INTEGER RANGE 0..100;
+
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+
+ REC1 : RECTYPE := (10,10,"0123456789");
+ REC2 : RECTYPE := (17,7,"C95087A..........");
+ REC3 : RECTYPE := (1,1,"A");
+ REC4 : RECTYPE; -- 80.
+
+ TASK T1 IS
+ ENTRY E1 (REC1 : IN RECTYPE := (2,0,"AB");
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE);
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (REC : OUT RECTYPE);
+ END T2;
+ END PKG;
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (REC1 : IN RECTYPE := (2,0,"AB");
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE) DO
+
+ IF REC1.CONSTRAINT /= IDENT_INT (10) THEN
+ FAILED ("RECORD TYPE IN PARAMETER " &
+ "DID NOT USE CONSTRAINT " &
+ "OF ACTUAL");
+ END IF;
+ IF REC2.CONSTRAINT /= IDENT_INT (17) THEN
+ FAILED ("RECORD TYPE OUT " &
+ "PARAMETER DID NOT USE " &
+ "CONSTRAINT OF ACTUAL");
+ END IF;
+ IF REC3.CONSTRAINT /= IDENT_INT (1) THEN
+ FAILED ("RECORD TYPE IN OUT " &
+ "PARAMETER DID NOT USE " &
+ "CONSTRAINT OF ACTUAL");
+ END IF;
+ REC2 := PKG.REC2;
+ END E1;
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (REC : OUT RECTYPE) DO
+ IF REC.CONSTRAINT /= IDENT_INT (80) THEN
+ FAILED ("RECORD TYPE OUT " &
+ "PARAMETER DID " &
+ "NOT USE CONSTRAINT OF " &
+ "UNINITIALIZED ACTUAL");
+ END IF;
+ REC := (10,10,"9876543210");
+ END E2;
+ END T2;
+ END PKG;
+
+ BEGIN -- (A)
+
+ PKG.T1.E1 (PKG.REC1, PKG.REC2, PKG.REC3);
+ PKG.T2.E2 (PKG.REC4);
+
+ END; -- (A)
+
+ ---------------------------------------------
+
+B : DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INT IS INTEGER RANGE 0..100;
+
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE;
+
+
+ TASK T1 IS
+ ENTRY E1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE);
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (REC : OUT RECTYPE);
+ END T2;
+
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC1 : PKG.RECTYPE (10);
+ REC2 : PKG.RECTYPE (17);
+ REC3 : PKG.RECTYPE (1);
+ REC4 : PKG.RECTYPE (10);
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE) DO
+ IF REC1.CONSTRAINT /= IDENT_INT (10) THEN
+ FAILED ("PRIVATE TYPE IN " &
+ "PARAMETER DID " &
+ "NOT USE CONSTRAINT OF " &
+ "ACTUAL");
+ END IF;
+ IF REC2.CONSTRAINT /= IDENT_INT (17) THEN
+ FAILED ("PRIVATE TYPE OUT " &
+ "PARAMETER DID " &
+ "NOT USE CONSTRAINT OF " &
+ "ACTUAL");
+ END IF;
+ IF REC3.CONSTRAINT /= IDENT_INT (1) THEN
+ FAILED ("PRIVATE TYPE IN OUT " &
+ "PARAMETER DID " &
+ "NOT USE CONSTRAINT OF " &
+ "ACTUAL");
+ END IF;
+ REC2 := B.REC2;
+ END E1;
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (REC : OUT RECTYPE) DO
+ IF REC.CONSTRAINT /= IDENT_INT (10) THEN
+ FAILED ("PRIVATE TYPE OUT " &
+ "PARAMETER DID " &
+ "NOT USE CONSTRAINT OF " &
+ "UNINITIALIZED ACTUAL");
+ END IF;
+ REC := (10,10,"9876543210");
+ END E2;
+ END T2;
+
+ BEGIN
+ REC1 := (10,10,"0123456789");
+ REC2 := (17,7,"C95087A..........");
+ REC3 := (1,1,"A");
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.T1.E1 (REC1, REC2, REC3);
+ PKG.T2.E2 (REC4);
+
+ END B; -- (B)
+
+ ---------------------------------------------
+
+C : DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INT IS INTEGER RANGE 0..100;
+
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ LIMITED PRIVATE;
+
+ TASK T1 IS
+ ENTRY E1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE);
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (REC : OUT RECTYPE);
+ END T2;
+
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC1 : PKG.RECTYPE; -- 10.
+ REC2 : PKG.RECTYPE; -- 17.
+ REC3 : PKG.RECTYPE; -- 1.
+ REC4 : PKG.RECTYPE; -- 80.
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE) DO
+ IF REC1.CONSTRAINT /= IDENT_INT (10) THEN
+ FAILED ("LIMITED PRIVATE TYPE IN " &
+ "PARAMETER DID NOT USE " &
+ "CONSTRAINT OF ACTUAL");
+ END IF;
+ IF REC2.CONSTRAINT /= IDENT_INT (17) THEN
+ FAILED ("LIMITED PRIVATE TYPE OUT " &
+ "PARAMETER DID NOT USE " &
+ "CONSTRAINT OF " &
+ "ACTUAL");
+ END IF;
+ IF REC3.CONSTRAINT /= IDENT_INT (1) THEN
+ FAILED ("LIMITED PRIVATE TYPE IN " &
+ "OUT PARAMETER DID NOT " &
+ "USE CONSTRAINT OF ACTUAL");
+ END IF;
+ REC2 := C.REC2;
+ END E1;
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (REC : OUT RECTYPE) DO
+ IF REC.CONSTRAINT /= IDENT_INT (80) THEN
+ FAILED ("LIMITED PRIVATE TYPE OUT " &
+ "PARAMETER DID NOT USE " &
+ "CONSTRAINT OF UNINITIALIZED " &
+ "ACTUAL");
+ END IF;
+ REC := (10,10,"9876543210");
+ END E2;
+ END T2;
+
+ BEGIN
+ REC1 := (10,10,"0123456789");
+ REC2 := (17,7,"C95087A..........");
+ REC3 := (1,1,"A");
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.T1.E1 (REC1, REC2, REC3);
+ PKG.T2.E2 (REC4);
+
+ END C; -- (C)
+
+ ---------------------------------------------
+
+D : DECLARE -- (D)
+
+ TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF
+ CHARACTER;
+
+ A1, A2, A3 : ATYPE (-1..1, 4..5) := (('A','B'),
+ ('C','D'),
+ ('E','F'));
+
+ A4 : ATYPE (-1..1, 4..5);
+
+ CA1 : CONSTANT ATYPE (8..9, -7..INTEGER'FIRST) :=
+ (8..9 => (-7..INTEGER'FIRST => 'A'));
+
+ S1 : STRING (1..INTEGER'FIRST) := "";
+ S2 : STRING (-5..-7) := "";
+ S3 : STRING (1..0) := "";
+
+ TASK T1 IS
+ ENTRY E1 (A1 : IN ATYPE := CA1;
+ A2 : OUT ATYPE;
+ A3 : IN OUT ATYPE);
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (A4 : OUT ATYPE);
+ END T2;
+
+ TASK T3 IS
+ ENTRY E3 (S1 : IN STRING;
+ S2 : IN OUT STRING;
+ S3 : OUT STRING);
+ END T3;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE;
+ A3 : IN OUT ATYPE) DO
+ IF A1'FIRST(1) /= IDENT_INT (-1) OR
+ A1'LAST(1) /= IDENT_INT (1) OR
+ A1'FIRST(2) /= IDENT_INT (4) OR
+ A1'LAST(2) /= IDENT_INT (5) THEN
+ FAILED ("ARRAY TYPE IN PARAMETER DID " &
+ "NOT USE CONSTRAINTS OF ACTUAL");
+ END IF;
+ IF A2'FIRST(1) /= IDENT_INT (-1) OR
+ A2'LAST(1) /= IDENT_INT (1) OR
+ A2'FIRST(2) /= IDENT_INT (4) OR
+ A2'LAST(2) /= IDENT_INT (5) THEN
+ FAILED ("ARRAY TYPE OUT PARAMETER DID " &
+ "NOT USE CONSTRAINTS OF ACTUAL");
+ END IF;
+ IF A3'FIRST(1) /= IDENT_INT (-1) OR
+ A3'LAST(1) /= IDENT_INT (1) OR
+ A3'FIRST(2) /= IDENT_INT (4) OR
+ A3'LAST(2) /= IDENT_INT (5) THEN
+ FAILED ("ARRAY TYPE IN OUT PARAMETER " &
+ "DID NOT USE CONSTRAINTS OF " &
+ "ACTUAL");
+ END IF;
+ A2 := D.A2;
+ END E1;
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (A4 : OUT ATYPE) DO
+ IF A4'FIRST(1) /= IDENT_INT (-1) OR
+ A4'LAST(1) /= IDENT_INT (1) OR
+ A4'FIRST(2) /= IDENT_INT (4) OR
+ A4'LAST(2) /= IDENT_INT (5) THEN
+ FAILED ("ARRAY TYPE OUT PARAMETER DID " &
+ "NOT USE CONSTRAINTS OF " &
+ "UNINITIALIZED ACTUAL");
+ END IF;
+ A4 := A2;
+ END E2;
+ END T2;
+
+ TASK BODY T3 IS
+ BEGIN
+ ACCEPT E3 (S1 : IN STRING;
+ S2 : IN OUT STRING;
+ S3 : OUT STRING) DO
+ IF S1'FIRST /= IDENT_INT (1) OR
+ S1'LAST /= IDENT_INT (INTEGER'FIRST) THEN
+ FAILED ("STRING TYPE IN PARAMETER DID " &
+ "NOT USE CONSTRAINTS OF ACTUAL " &
+ "NULL STRING");
+ END IF;
+ IF S2'FIRST /= IDENT_INT (-5) OR
+ S2'LAST /= IDENT_INT (-7) THEN
+ FAILED ("STRING TYPE IN OUT PARAMETER " &
+ "DID NOT USE CONSTRAINTS OF " &
+ "ACTUAL NULL STRING");
+ END IF;
+ IF S3'FIRST /= IDENT_INT (1) OR
+ S3'LAST /= IDENT_INT (0) THEN
+ FAILED ("STRING TYPE OUT PARAMETER DID NOT " &
+ "USE CONSTRAINTS OF ACTUAL NULL " &
+ "STRING");
+ END IF;
+ S3 := "";
+ END E3;
+ END T3;
+
+ BEGIN -- (D)
+
+ T1.E1 (A1, A2, A3);
+ T2.E2 (A4);
+ T3.E3 (S1, S2, S3);
+
+ END D; -- (D)
+
+ RESULT;
+END C95087A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087b.ada b/gcc/testsuite/ada/acats/tests/c9/c95087b.ada
new file mode 100644
index 000000000..1d6c87826
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95087b.ada
@@ -0,0 +1,267 @@
+-- C95087B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED
+-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT
+-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE
+-- THE CONSTRAINT OF THE ACTUAL PARAMETER.
+-- SUBTESTS ARE:
+-- (A) RECORD TYPE.
+-- (B) PRIVATE TYPE.
+-- (C) LIMITED PRIVATE TYPE.
+
+-- RJW 1/10/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95087B IS
+
+BEGIN
+
+ TEST ( "C95087B", "CHECK ASSIGNMENT TO ENTRY FORMAL PARAMETERS " &
+ "OF UNCONSTRAINED TYPE (WITH NO DEFAULT)" );
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+
+ TASK T IS
+ ENTRY E (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE);
+ END T;
+
+ END PKG;
+
+ REC9 : PKG.RECTYPE(IDENT_INT(9)) :=
+ (IDENT_INT(9), 9, "123456789");
+ REC6 : PKG.RECTYPE(IDENT_INT(6)) :=
+ (IDENT_INT(6), 5, "AEIOUY");
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+
+ REC4 : CONSTANT RECTYPE(IDENT_INT(4)) :=
+ (IDENT_INT(4), 4, "OOPS");
+
+ BEGIN
+ ACCEPT E (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE) DO
+
+ BEGIN -- (A.1)
+ REC9 := REC6;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED " &
+ "- A.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED " &
+ "- A.1");
+ END; -- (A.1)
+
+ BEGIN -- (A.2)
+ REC6 := REC4;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED " &
+ "- A.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED " &
+ "- A.2");
+ END; -- (A.2)
+
+ REC9 := (IDENT_INT(9), 9, "987654321");
+
+ END E;
+ END T;
+ END PKG;
+
+ BEGIN -- (A)
+
+ PKG.T.E (REC9, REC6);
+
+ IF REC9.STRFIELD /= IDENT_STR("987654321") THEN
+ FAILED ("ASSIGNMENT TO REC9 FAILED - (A)");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE;
+
+ TASK T IS
+ ENTRY E (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE);
+ END T;
+
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC9 : PKG.RECTYPE(9);
+ REC6 : PKG.RECTYPE(6);
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+
+ REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
+
+ BEGIN
+ ACCEPT E (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE) DO
+
+ BEGIN -- (B.1)
+ REC9 := REC6;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED " &
+ "- B.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED " &
+ "- B.1");
+ END; -- (B.1)
+
+ BEGIN -- (B.2)
+ REC6 := REC4;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED " &
+ "- B.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED " &
+ "- B.2");
+ END; -- (B.2)
+
+ END E;
+ END T;
+
+ BEGIN
+ REC9 := (9, 9, "123456789");
+ REC6 := (6, 5, "AEIOUY");
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.T.E (REC9, REC6);
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE;
+
+ TASK T IS
+ ENTRY E (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE);
+ END T;
+
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC6 : PKG.RECTYPE(IDENT_INT(6));
+ REC9 : PKG.RECTYPE(IDENT_INT(9));
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+
+ REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
+
+ BEGIN
+ ACCEPT E (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE) DO
+
+ BEGIN -- (C.1)
+ REC9 := REC6;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED " &
+ "- C.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED " &
+ "- C.1");
+ END; -- (C.1)
+
+ BEGIN -- (C.2)
+ REC6 := REC4;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED " &
+ "- C.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED " &
+ "- C.2");
+ END; -- (C.2)
+
+ END E;
+ END T;
+
+ BEGIN
+ REC6 := (6, 5, "AEIOUY");
+ REC9 := (9, 9, "123456789");
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.T.E (REC9, REC6);
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C95087B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087c.ada b/gcc/testsuite/ada/acats/tests/c9/c95087c.ada
new file mode 100644
index 000000000..2061af4bc
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95087c.ada
@@ -0,0 +1,299 @@
+-- C95087C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED
+-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
+-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS
+-- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING
+-- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER.
+
+-- SUBTESTS ARE:
+-- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
+-- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
+-- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
+
+-- RJW 1/15/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95087C IS
+
+BEGIN
+
+ TEST ( "C95087C", "CHECK ASSIGNMENTS TO ENTRY FORMAL " &
+ "PARAMETERS OF UNCONSTRAINED TYPES " &
+ "(WITH DEFAULTS)" );
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+
+ REC91,REC92,REC93 : RECTYPE(9);
+ REC_OOPS : RECTYPE(4);
+
+ TASK T IS
+ ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END T;
+
+ END PKG;
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) DO
+
+ IF (NOT REC1'CONSTRAINED) OR
+ (REC1.CONSTRAINT /= IDENT_INT(9)) THEN
+ FAILED ( "CONSTRAINT ON RECORD TYPE " &
+ "IN PARAMETER NOT RECOGNIZED" );
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER.
+ REC2 := REC_OOPS;
+ FAILED ( "CONSTRAINT_ERROR NOT " &
+ "RAISED - A.1" );
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "WRONG EXCEPTION " &
+ "RAISED - A.1" );
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER.
+ REC3 := REC_OOPS;
+ FAILED ( "CONSTRAINT_ERROR NOT " &
+ "RAISED - A.2" );
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "WRONG EXCEPTION " &
+ "RAISED - A.2" );
+ END;
+
+ END E;
+ END T;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (A)
+
+ PKG.T.E (PKG.REC91, PKG.REC92, PKG.REC93);
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
+
+ TASK T IS
+ ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END T;
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE(9);
+ REC_OOPS : PKG.RECTYPE(4);
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) DO
+
+ IF (NOT REC1'CONSTRAINED) OR
+ (REC1.CONSTRAINT /= IDENT_INT(9)) THEN
+ FAILED ( "CONSTRAINT ON PRIVATE TYPE " &
+ "IN PARAMETER NOT RECOGNIZED" );
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER.
+ REC2 := REC_OOPS;
+ FAILED ( "CONSTRAINT_ERROR NOT " &
+ "RAISED - B.1" );
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "WRONG EXCEPTION " &
+ "RAISED - B.1" );
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER.
+ REC3 := REC_OOPS;
+ FAILED ( "CONSTRAINT_ERROR NOT " &
+ "RAISED - B.2" );
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "WRONG EXCEPTION " &
+ "RAISED - B.2" );
+ END;
+
+ END E;
+ END T;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.T.E (REC91, REC92, REC93);
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ LIMITED PRIVATE;
+
+ TASK T IS
+ ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END T;
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91,REC92,REC93 : PKG.RECTYPE(9);
+ REC_OOPS : PKG.RECTYPE(4);
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) DO
+
+ IF (NOT REC1'CONSTRAINED) OR
+ (REC1.CONSTRAINT /= 9) THEN
+ FAILED ( "CONSTRAINT ON LIMITED " &
+ "PRIVATE TYPE IN PARAMETER " &
+ "NOT RECOGNIZED" );
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER.
+ REC2 := REC_OOPS;
+ FAILED ( "CONSTRAINT_ERROR NOT " &
+ "RAISED - C.1" );
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "WRONG EXCEPTION " &
+ "RAISED - C.1" );
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER.
+ REC3 := REC_OOPS;
+ FAILED ( "CONSTRAINT_ERROR NOT RAISED " &
+ "- C.2" );
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ( "WRONG EXCEPTION " &
+ "RAISED - C.2" );
+ END;
+
+ END E;
+ END T;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.T.E (REC91, REC92, REC93);
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C95087C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087d.ada b/gcc/testsuite/ada/acats/tests/c9/c95087d.ada
new file mode 100644
index 000000000..6e44913b4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95087d.ada
@@ -0,0 +1,268 @@
+-- C95087D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED
+-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
+-- CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER
+-- IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT
+-- BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER.
+
+-- SUBTESTS ARE:
+-- (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
+-- (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
+-- (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
+
+-- RJW 1/17/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95087D IS
+
+BEGIN
+
+ TEST ( "C95087D", "CHECK ASSIGNMENTS TO ENTRY FORMAL PARAMETERS " &
+ "OF UNCONSTRAINED TYPES WITH UNCONSTRAINED " &
+ "ACTUAL PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+
+ TASK T IS
+ ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END T;
+
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE :=
+ (IDENT_INT(5), 5, IDENT_STR( "12345"));
+ REC_OOPS : PKG.RECTYPE;
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) DO
+
+ IF NOT REC1'CONSTRAINED THEN
+ FAILED ( "REC1 IS NOT CONSTRAINED - A.1");
+ END IF;
+ IF REC1.CONSTRAINT /= IDENT_INT(9) THEN
+ FAILED ( "REC1 CONSTRAINT IS NOT 9 " &
+ "- A.1");
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER.
+ REC2 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - A.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER.
+ REC3 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - A.2");
+ END;
+
+ END E;
+ END T;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ USE PKG;
+
+ BEGIN -- (A)
+
+ PKG.T.E (REC91, REC92, REC93);
+ IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN
+ FAILED ( "RESULTANT VALUE OF REC92 OR REC93 INCORRECT");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
+
+ TASK T IS
+ ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END T;
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE;
+ REC_OOPS : PKG.RECTYPE;
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) DO
+
+ IF REC3'CONSTRAINED THEN
+ FAILED ( "REC3 IS CONSTRAINED - B.1");
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER.
+ REC2 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - B.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER.
+ REC3 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - B.2");
+ END;
+
+ END E;
+ END T;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.T.E (REC91, REC92, REC93);
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ LIMITED PRIVATE;
+
+ TASK T IS
+ ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END T;
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE;
+ REC_OOPS : PKG.RECTYPE;
+
+ PACKAGE BODY PKG IS
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) DO
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER.
+ REC2 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - C.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER.
+ REC3 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ( "EXCEPTION RAISED - C.2");
+ END;
+
+ END E;
+ END T;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.T.E (REC91, REC92, REC93);
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C95087D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95088a.ada b/gcc/testsuite/ada/acats/tests/c9/c95088a.ada
new file mode 100644
index 000000000..053abebdd
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95088a.ada
@@ -0,0 +1,85 @@
+-- C95088A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ACTUAL PARAMETERS ARE EVALUATED AND IDENTIFIED AT THE
+-- TIME OF CALL.
+
+-- GLH 7/10/85
+
+WITH REPORT; USE REPORT;
+
+PROCEDURE C95088A IS
+
+ TYPE VECTOR IS ARRAY (1..10) OF INTEGER;
+ TYPE PTRINT IS ACCESS INTEGER;
+
+ I : INTEGER := 1;
+ A : VECTOR := (1,2,3,4,5,6,7,8,9,10);
+ P1 : PTRINT := NEW INTEGER'(2);
+ P2 : PTRINT := P1;
+
+ TASK T1 IS
+ ENTRY E1 (I : OUT INTEGER; J : OUT INTEGER);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (I : OUT INTEGER; J : OUT INTEGER) DO
+ I := 10;
+ J := -1;
+ END E1;
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (P : OUT PTRINT; I : OUT INTEGER);
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (P : OUT PTRINT; I : OUT INTEGER) DO
+ P := NEW INTEGER'(3);
+ I := 5;
+ END E2;
+ END T2;
+
+BEGIN
+
+ TEST ("C95088A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED " &
+ "AND IDENTIFIED AT THE TIME OF CALL");
+
+ COMMENT ("FIRST CALL");
+ T1.E1 (I, A(I));
+ IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN
+ FAILED ("A(I) EVALUATED UPON RETURN");
+ END IF;
+
+ COMMENT ("SECOND CALL");
+ T2.E2 (P1, P1.ALL);
+ IF (P2.ALL /= 5) THEN
+ FAILED ("P1.ALL EVALUATED UPON RETURN");
+ END IF;
+
+ RESULT;
+
+END C95088A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95089a.ada b/gcc/testsuite/ada/acats/tests/c9/c95089a.ada
new file mode 100644
index 000000000..b66897cc7
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95089a.ada
@@ -0,0 +1,175 @@
+-- C95089A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ALL PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED
+-- AS ACTUAL PARAMETERS.
+
+-- GLH 7/25/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95089A IS
+
+ SUBTYPE INT IS INTEGER RANGE 1..3;
+
+ TYPE REC (N : INT) IS
+ RECORD
+ S : STRING (1..N);
+ END RECORD;
+
+ TYPE PTRSTR IS ACCESS STRING;
+
+ R1, R2, R3 : REC (3);
+ S1, S2, S3 : STRING (1..3);
+ PTRTBL : ARRAY (1..3) OF PTRSTR;
+
+ TASK T1 IS
+ ENTRY E1 (S1 : IN STRING; S2: IN OUT STRING;
+ S3 : OUT STRING);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E1 (S1 : IN STRING; S2: IN OUT STRING;
+ S3 : OUT STRING) DO
+ S3 := S2;
+ S2 := S1;
+ END E1;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER;
+ C3 : OUT CHARACTER);
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER;
+ C3 : OUT CHARACTER) DO
+ C3 := C2;
+ C2 := C1;
+ END E2;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T2;
+
+ FUNCTION F1 (X : INT) RETURN PTRSTR IS
+ BEGIN
+ RETURN PTRTBL (X);
+ END F1;
+
+ FUNCTION "+" (S1, S2 : STRING) RETURN PTRSTR IS
+ BEGIN
+ RETURN PTRTBL (CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1);
+ END "+";
+
+BEGIN
+
+ TEST ("C95089A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE " &
+ "NAMES ARE PERMITTED AS ACTUAL PARAMETERS");
+
+ S1 := "AAA";
+ S2 := "BBB";
+ T1.E1 (S1, S2, S3);
+ IF S2 /= "AAA" OR S3 /= "BBB" THEN
+ FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING");
+ END IF;
+
+ S1 := "AAA";
+ S2 := "BBB";
+ S3 := IDENT_STR ("CCC");
+ T2.E2 (S1(1), S2(IDENT_INT(1)), S3(1));
+ IF S2 /= "ABB" OR S3 /= "BCC" THEN
+ FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " &
+ "WORKING");
+ END IF;
+
+ R1.S := "AAA";
+ R2.S := "BBB";
+ T1.E1 (R1.S, R2.S, R3.S);
+ IF R2.S /= "AAA" OR R3.S /= "BBB" THEN
+ FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER " &
+ "NOT WORKING");
+ END IF;
+
+ S1 := "AAA";
+ S2 := "BBB";
+ T1.E1 (S1(1..IDENT_INT(2)), S2(1..2),
+ S3(IDENT_INT(1)..IDENT_INT(2)));
+ IF S2 /= "AAB" OR S3 /= "BBC" THEN
+ FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ T1.E1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL);
+ IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN
+ FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " &
+ "PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ S1 := IDENT_STR("AAA");
+ S2 := IDENT_STR("BBB");
+ S3 := IDENT_STR("CCC");
+ T1.E1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL);
+ IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN
+ FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR " &
+ "FUNCTION VALUE AS AN ACTUAL PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ T2.E2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1)));
+ IF PTRTBL(2).ALL /= "ABB" OR PTRTBL(3).ALL /= "BCC" THEN
+ FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " &
+ "PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ T1.E1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3),
+ F1(3)(2..IDENT_INT(3)));
+ IF PTRTBL(2).ALL /= "BAA" OR PTRTBL(3).ALL /= "CBB" THEN
+ FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER " &
+ "NOT WORKING");
+ END IF;
+
+ RESULT;
+
+END C95089A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95090a.ada b/gcc/testsuite/ada/acats/tests/c9/c95090a.ada
new file mode 100644
index 000000000..24dc17981
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95090a.ada
@@ -0,0 +1,128 @@
+-- C95090A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
+-- TO ENTRIES. SPECIFICALLY,
+-- (A) CHECK ALL PARAMETER MODES.
+
+-- GLH 7/25/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95090A IS
+
+BEGIN
+ TEST ("C95090A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
+ "RECORDS ARE PASSED CORRECTLY TO ENTRIES");
+
+ --------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
+ SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE (1..IDENT_INT(5));
+
+ TYPE RECORD_TYPE IS
+ RECORD
+ I : INTEGER;
+ A : ARRAY_SUBTYPE;
+ END RECORD;
+
+ REC : RECORD_TYPE := (I => 23,
+ A => (1..3 => IDENT_INT(7), 4..5 => 9));
+ BOOL : BOOLEAN;
+
+ TASK T1 IS
+ ENTRY E1 (ARR : ARRAY_TYPE);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 (ARR : ARRAY_TYPE) DO
+ IF ARR /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT (1) OR
+ ARR'LAST /= IDENT_INT (5) THEN
+ FAILED ("WRONG BOUNDS FOR IN PARAMETER");
+ END IF;
+ END E1;
+ END T1;
+
+ TASK T2 IS
+ ENTRY E2 (ARR : IN OUT ARRAY_TYPE);
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E2 (ARR : IN OUT ARRAY_TYPE) DO
+ IF ARR /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN OUT PARAMETER NOT PASSED " &
+ "CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT (1) OR
+ ARR'LAST /= IDENT_INT (5) THEN
+ FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER");
+ END IF;
+ ARR := (ARR'RANGE => 5);
+ END E2;
+ END T2;
+
+ TASK T3 IS
+ ENTRY E3 (ARR : OUT ARRAY_TYPE);
+ END T3;
+
+ TASK BODY T3 IS
+ BEGIN
+ ACCEPT E3 (ARR : OUT ARRAY_TYPE) DO
+ IF ARR'FIRST /= IDENT_INT (1) OR
+ ARR'LAST /= IDENT_INT (5) THEN
+ FAILED ("WRONG BOUNDS FOR OUT PARAMETER");
+ END IF;
+ ARR := (ARR'RANGE => 3);
+ END E3;
+ END T3;
+
+ BEGIN -- (A)
+
+ T1.E1 (REC.A);
+ IF REC.A /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+
+ T2.E2 (REC.A);
+ IF REC.A /= (5, 5, 5, 5, 5) THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+
+ T3.E3 (REC.A);
+ IF REC.A /= (3, 3, 3, 3, 3) THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------
+
+ RESULT;
+END C95090A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95092a.ada b/gcc/testsuite/ada/acats/tests/c9/c95092a.ada
new file mode 100644
index 000000000..47e96b548
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95092a.ada
@@ -0,0 +1,193 @@
+-- C95092A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT FOR ENTRIES OF TASKS, DEFAULT VALUES OF ALL TYPES CAN
+-- BE GIVEN FOR A FORMAL PARAMETER.
+
+-- HISTORY:
+-- DHH 03/22/88 CREATED ORIGINAL TEST.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95092A IS
+
+ SUBTYPE INT IS INTEGER RANGE 1 ..10;
+ TYPE FLT IS DIGITS 5;
+ TYPE FIX IS DELTA 0.125 RANGE 0.0 .. 10.0;
+ TYPE ENUM IS (RED, BLUE, YELLOW);
+ SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'F';
+ TYPE ARR IS ARRAY(1 .. 3) OF INTEGER;
+ TYPE REC IS
+ RECORD
+ A : INT;
+ B : ENUM;
+ C : CHAR;
+ END RECORD;
+
+ FUNCTION IDENT_FLT(E : FLT) RETURN FLT IS
+ BEGIN
+ IF EQUAL(3,3) THEN
+ RETURN E;
+ ELSE
+ RETURN 0.0;
+ END IF;
+ END IDENT_FLT;
+
+ FUNCTION IDENT_FIX(E : FIX) RETURN FIX IS
+ BEGIN
+ IF EQUAL(3,3) THEN
+ RETURN E;
+ ELSE
+ RETURN 0.0;
+ END IF;
+ END IDENT_FIX;
+
+ FUNCTION IDENT_ENUM(E : ENUM) RETURN ENUM IS
+ BEGIN
+ IF EQUAL(3,3) THEN
+ RETURN E;
+ ELSE
+ RETURN YELLOW;
+ END IF;
+ END IDENT_ENUM;
+
+ FUNCTION IDENT_CHAR(E : CHAR) RETURN CHAR IS
+ BEGIN
+ IF EQUAL(3,3) THEN
+ RETURN E;
+ ELSE
+ RETURN 'F';
+ END IF;
+ END IDENT_CHAR;
+
+ FUNCTION IDENT_ARR(E : ARR) RETURN ARR IS
+ Z : ARR := (3,2,1);
+ BEGIN
+ IF EQUAL(3,3) THEN
+ RETURN E;
+ ELSE
+ RETURN Z;
+ END IF;
+ END IDENT_ARR;
+
+ FUNCTION IDENT_REC(E : REC) RETURN REC IS
+ Z : REC := (10, YELLOW, 'F');
+ BEGIN
+ IF EQUAL(3,3) THEN
+ RETURN E;
+ ELSE
+ RETURN Z;
+ END IF;
+ END IDENT_REC;
+
+ TASK TEST_DEFAULTS IS
+ ENTRY BOOL(G : BOOLEAN := TRUE);
+ ENTRY INTEGR(X : IN INT := 5);
+ ENTRY FLOAT(Y : IN FLT := 1.25);
+ ENTRY FIXED(Z : IN FIX := 1.0);
+ ENTRY ENUMERAT(A : IN ENUM := RED);
+ ENTRY CHARACTR(B : IN CHAR := 'A');
+ ENTRY ARRY(C : IN ARR := (1, 2, 3));
+ ENTRY RECD(D : IN REC := (5, RED, 'A'));
+ END TEST_DEFAULTS;
+
+ TASK BODY TEST_DEFAULTS IS
+ BEGIN
+
+ ACCEPT BOOL(G : BOOLEAN := TRUE) DO
+ IF G /= IDENT_BOOL(TRUE) THEN
+ FAILED("BOOLEAN DEFAULT FAILED");
+ END IF;
+ END BOOL;
+
+ ACCEPT INTEGR(X : IN INT := 5) DO
+ IF X /= IDENT_INT(5) THEN
+ FAILED("INTEGER DEFAULT FAILED");
+ END IF;
+ END INTEGR;
+
+ ACCEPT FLOAT(Y : IN FLT := 1.25) DO
+ IF Y /= IDENT_FLT(1.25) THEN
+ FAILED("FLOAT DEFAULT FAILED");
+ END IF;
+ END FLOAT;
+
+ ACCEPT FIXED(Z : IN FIX := 1.0) DO
+ IF Z /= IDENT_FIX(1.0) THEN
+ FAILED("FIXED DEFAULT FAILED");
+ END IF;
+ END FIXED;
+
+ ACCEPT ENUMERAT(A : IN ENUM := RED) DO
+ IF A /= IDENT_ENUM(RED) THEN
+ FAILED("ENUMERATION DEFAULT FAILED");
+ END IF;
+ END ENUMERAT;
+
+ ACCEPT CHARACTR(B : IN CHAR := 'A') DO
+ IF B /= IDENT_CHAR('A') THEN
+ FAILED("CHARACTER DEFAULT FAILED");
+ END IF;
+ END CHARACTR;
+
+ ACCEPT ARRY(C : IN ARR := (1, 2, 3)) DO
+ FOR I IN 1 ..3 LOOP
+ IF C(I) /= IDENT_INT(I) THEN
+ FAILED("ARRAY " & INTEGER'IMAGE(I) &
+ "DEFAULT FAILED");
+ END IF;
+ END LOOP;
+ END ARRY;
+
+ ACCEPT RECD(D : IN REC := (5, RED, 'A')) DO
+ IF D.A /= IDENT_INT(5) THEN
+ FAILED("RECORD INTEGER DEFAULT FAILED");
+ END IF;
+ IF D.B /= IDENT_ENUM(RED) THEN
+ FAILED("RECORD ENUMERATION DEFAULT FAILED");
+ END IF;
+ IF D.C /= IDENT_CHAR('A') THEN
+ FAILED("RECORD CHARACTER DEFAULT FAILED");
+ END IF;
+ END RECD;
+
+ END TEST_DEFAULTS;
+
+BEGIN
+
+ TEST("C95092A", "CHECK THAT FOR ENTRIES OF TASKS, DEFAULT " &
+ "VALUES OF ALL TYPES CAN BE GIVEN FOR A FORMAL " &
+ "PARAMETER");
+
+ TEST_DEFAULTS.BOOL;
+ TEST_DEFAULTS.INTEGR;
+ TEST_DEFAULTS.FLOAT;
+ TEST_DEFAULTS.FIXED;
+ TEST_DEFAULTS.ENUMERAT;
+ TEST_DEFAULTS.CHARACTR;
+ TEST_DEFAULTS.ARRY;
+ TEST_DEFAULTS.RECD;
+
+ RESULT;
+END C95092A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95093a.ada b/gcc/testsuite/ada/acats/tests/c9/c95093a.ada
new file mode 100644
index 000000000..9c443faae
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95093a.ada
@@ -0,0 +1,87 @@
+-- C95093A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE DEFAULT EXPRESSIONS OF FORMAL PARAMETERS ARE EVALUATED
+-- EACH TIME THEY ARE NEEDED.
+
+-- GLH 7/2/85
+
+WITH REPORT; USE REPORT;
+
+PROCEDURE C95093A IS
+BEGIN
+
+ TEST ("C95093A", "CHECK THAT THE DEFAULT EXPRESSION IS " &
+ "EVALUATED EACH TIME IT IS NEEDED");
+
+ DECLARE
+
+ X : INTEGER := 1;
+
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ X := X + 1;
+ RETURN X;
+ END F;
+
+ TASK T1 IS
+ ENTRY E1 (X, Y : INTEGER := F);
+ END T1;
+
+ TASK BODY T1 IS
+ BEGIN
+
+ ACCEPT E1 (X, Y : INTEGER := F) DO
+ IF X = Y OR Y /= 2 THEN
+ FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " &
+ "1, X =" & INTEGER'IMAGE(X) &
+ ", Y =" & INTEGER'IMAGE(Y));
+ END IF;
+ END E1;
+
+ ACCEPT E1 (X, Y : INTEGER := F) DO
+ IF X = Y OR
+ NOT ((X = 3 AND Y = 4) OR
+ (X = 4 AND Y = 3)) THEN
+ FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " &
+ "2, X =" & INTEGER'IMAGE(X) &
+ ", Y =" & INTEGER'IMAGE(Y));
+ END IF;
+ END E1;
+
+ END T1;
+
+ BEGIN
+
+ COMMENT ("FIRST CALL");
+ T1.E1 (3);
+
+ COMMENT ("SECOND CALL");
+ T1.E1;
+
+ END;
+
+ RESULT;
+
+END C95093A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095a.ada b/gcc/testsuite/ada/acats/tests/c9/c95095a.ada
new file mode 100644
index 000000000..0cd02958d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95095a.ada
@@ -0,0 +1,108 @@
+-- C95095A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (A) A FUNCTION AND AN ENTRY.
+
+-- JWC 7/24/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95095A IS
+
+BEGIN
+ TEST ("C95095A", "SUBPROGRAM/ENTRY OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES");
+
+ --------------------------------------------------
+
+ -- BOTH PARAMETERIZED AND PARAMETERLESS SUBPROGRAMS AND ENTRIES
+ -- ARE TESTED.
+
+ DECLARE
+ I, J, K : INTEGER := 0;
+ S : STRING (1..2) := "12";
+
+ TASK T IS
+ ENTRY E1 (I1, I2 : INTEGER);
+ ENTRY E2;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E1 (I1, I2 : INTEGER) DO
+ S (1) := 'A';
+ END E1;
+ OR
+ ACCEPT E2 DO
+ S (1) := 'C';
+ END E2;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ FUNCTION E1 (I1, I2 : INTEGER) RETURN INTEGER IS
+ BEGIN
+ S (2) := 'B';
+ RETURN I1; -- RETURNED VALUE IS IRRELEVENT.
+ END E1;
+
+
+ FUNCTION E2 RETURN INTEGER IS
+ BEGIN
+ S (2) := 'D';
+ RETURN I; -- RETURNED VALUE IS IRRELEVENT.
+ END E2;
+
+ BEGIN
+ T.E1 (I, J);
+ K := E1 (I, J);
+
+ IF S /= "AB" THEN
+ FAILED ("PARAMETERIZED OVERLOADED " &
+ "SUBPROGRAM AND ENTRY " &
+ "CAUSED CONFUSION");
+ END IF;
+
+ S := "12";
+ T.E2;
+ K := E2;
+
+ IF S /= "CD" THEN
+ FAILED ("PARAMETERLESS OVERLOADED " &
+ "SUBPROGRAM AND ENTRY " &
+ "CAUSED CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95095A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095b.ada b/gcc/testsuite/ada/acats/tests/c9/c95095b.ada
new file mode 100644
index 000000000..f3c9c0df5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95095b.ada
@@ -0,0 +1,112 @@
+-- C95095B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT OVERLOADED ENTRY DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (B) ONE ENTRY HAS ONE LESS PARAMETER THAN THE OTHER.
+
+-- JWC 7/24/85
+-- JRK 10/2/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95095B IS
+
+BEGIN
+ TEST ("C95095B", "ENTRY OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES");
+
+ --------------------------------------------------
+
+ -- ONE ENTRY HAS ONE MORE PARAMETER
+ -- THAN THE OTHER. THIS IS TESTED IN THE
+ -- CASE IN WHICH THAT PARAMETER HAS A DEFAULT
+ -- VALUE, AND THE CASE IN WHICH IT DOES NOT.
+
+ DECLARE
+ I, J : INTEGER := 0;
+ B : BOOLEAN := TRUE;
+ S : STRING (1..2) := "12";
+
+ TASK T IS
+ ENTRY E1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN);
+ ENTRY E1 (I1, I2 : INTEGER);
+ ENTRY E2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0);
+ ENTRY E2 (B1 : IN OUT BOOLEAN);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E1 (I1, I2 : INTEGER;
+ B1 : IN OUT BOOLEAN) DO
+ S (1) := 'A';
+ END E1;
+ OR
+ ACCEPT E1 (I1, I2 : INTEGER) DO
+ S (2) := 'B';
+ END E1;
+ OR
+ ACCEPT E2 (B1 : IN OUT BOOLEAN;
+ I1 : INTEGER := 0) DO
+ S (1) := 'C';
+ END E2;
+ OR
+ ACCEPT E2 (B1 : IN OUT BOOLEAN) DO
+ S (2) := 'D';
+ END E2;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ BEGIN
+ T.E1 (I, J, B);
+ T.E1 (I, J);
+
+ IF S /= "AB" THEN
+ FAILED ("ENTRIES DIFFERING ONLY IN " &
+ "NUMBER OF PARAMETERS (NO DEFAULTS) " &
+ "CAUSED CONFUSION");
+ END IF;
+
+ S := "12";
+ T.E2 (B, I);
+ -- NOTE THAT A CALL TO T.E2 WITH ONLY
+ -- ONE PARAMETER IS AMBIGUOUS.
+
+ IF S /= "C2" THEN
+ FAILED ("ENTRIES DIFFERING ONLY IN " &
+ "EXISTENCE OF ONE PARAMETER (WITH " &
+ "DEFAULT) CAUSED CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95095B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095c.ada b/gcc/testsuite/ada/acats/tests/c9/c95095c.ada
new file mode 100644
index 000000000..694c7d31e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95095c.ada
@@ -0,0 +1,97 @@
+-- C95095C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT OVERLOADED ENTRY DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (C) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT
+-- OF THE CORRESPONDING ONE.
+
+-- JWC 7/24/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95095C IS
+
+BEGIN
+ TEST ("C95095C", "ENTRY OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES");
+
+ --------------------------------------------------
+
+ -- THE BASE TYPE OF ONE PARAMETER IS
+ -- DIFFERENT FROM THAT OF THE CORRESPONDING
+ -- ONE.
+
+ DECLARE
+
+ TYPE NEWINT IS NEW INTEGER;
+
+ I, J, K : INTEGER := 0;
+ N : NEWINT;
+ S : STRING (1..2) := "12";
+
+ TASK T IS
+ ENTRY E (I1 : INTEGER; N1 : OUT NEWINT;
+ I2 : IN OUT INTEGER);
+ ENTRY E (I1 : INTEGER; N1 : OUT INTEGER;
+ I2 : IN OUT INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT E (I1 : INTEGER; N1 : OUT NEWINT;
+ I2 : IN OUT INTEGER) DO
+ S (1) := 'A';
+ N1 := 0; -- THIS VALUE IS IRRELEVENT.
+ END E;
+ OR
+ ACCEPT E (I1 : INTEGER; N1 : OUT INTEGER;
+ I2 : IN OUT INTEGER) DO
+ S (2) := 'B';
+ N1 := 0; -- THIS VALUE IS IRRELEVENT.
+ END E;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ BEGIN
+ T.E (I, N, K);
+ T.E (I, J, K);
+
+ IF S /= "AB" THEN
+ FAILED ("ENTRIES DIFFERING ONLY BY " &
+ "THE BASE TYPE OF A PARAMETER " &
+ "CAUSED CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95095C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095d.ada b/gcc/testsuite/ada/acats/tests/c9/c95095d.ada
new file mode 100644
index 000000000..f2ad7d95a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95095d.ada
@@ -0,0 +1,99 @@
+-- C95095D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (D) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE
+-- PART, AN ENTRY IS DECLARED IN A TASK, AND THE
+-- PARAMETERS ARE ORDERED DIFFERENTLY.
+
+-- JWC 7/24/85
+-- JRK 10/2/85
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C95095D IS
+
+
+BEGIN
+ TEST ("C95095D", "SUBPROGRAM/ENTRY OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES");
+
+ --------------------------------------------------
+
+ -- A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE
+ -- PART, AN ENTRY IS DECLARED IN A TASK, AND THE
+ -- PARAMETERS ARE ORDERED DIFFERENTLY.
+
+ DECLARE
+ S : STRING (1..2) := "12";
+
+ I : INTEGER := 0;
+
+ PROCEDURE E (I1 : INTEGER; I2 : IN OUT INTEGER;
+ B1 : BOOLEAN) IS
+ BEGIN
+ S (1) := 'A';
+ END E;
+
+ TASK T IS
+ ENTRY E (B1 : BOOLEAN; I1 : INTEGER;
+ I2 : IN OUT INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ E (5, I, TRUE); -- PROCEDURE CALL.
+ ACCEPT E (B1 : BOOLEAN; I1 : INTEGER;
+ I2 : IN OUT INTEGER) DO
+ S (2) := 'B';
+ END E;
+ E (TRUE, 5, I); -- ENTRY CALL; SELF-BLOCKING.
+ -- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS
+ -- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS.
+ FAILED ("TASK DID NOT BLOCK ITSELF");
+ END T;
+
+ BEGIN
+
+ T.E (TRUE, 5, I);
+
+ DELAY 10.0 * Impdef.One_Second;
+ ABORT T;
+
+ IF S /= "AB" THEN
+ FAILED ("PROCEDURES/ENTRIES " &
+ "DIFFERING ONLY IN PARAMETER " &
+ "TYPE ORDER CAUSED CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95095D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095e.ada b/gcc/testsuite/ada/acats/tests/c9/c95095e.ada
new file mode 100644
index 000000000..01951691f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c95095e.ada
@@ -0,0 +1,88 @@
+-- C95095E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (E) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART,
+-- AN ENTRY IN A TASK, AND ONE HAS ONE MORE PARAMETER
+-- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE.
+
+-- JWC 7/30/85
+-- JRK 10/2/85
+
+WITH REPORT; USE REPORT;
+PROCEDURE C95095E IS
+
+BEGIN
+ TEST ("C95095E", "SUBPROGRAM/ENTRY OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES ALLOWED");
+
+ --------------------------------------------------
+
+ -- A SUBPROGRAM IS IN AN OUTER DECLARATIVE
+ -- PART, AN ENTRY IN A TASK, AND ONE
+ -- HAS ONE MORE PARAMETER (WITH A DEFAULT
+ -- VALUE) THAN THE OTHER.
+
+ DECLARE
+ S : STRING (1..3) := "123";
+
+ PROCEDURE E (I1, I2, I3 : INTEGER := 1) IS
+ C : CONSTANT STRING := "CXA";
+ BEGIN
+ S (I3) := C (I3);
+ END E;
+
+ TASK T IS
+ ENTRY E (I1, I2 : INTEGER := 1);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (I1, I2 : INTEGER := 1) DO
+ S (2) := 'B';
+ END E;
+ END T;
+
+ BEGIN
+
+ E (1, 2, 3);
+ T.E (1, 2);
+ E (1, 2);
+
+ IF S /= "CBA" THEN
+ FAILED ("PROCEDURES/ENTRIES DIFFERING " &
+ "ONLY IN EXISTENCE OF ONE " &
+ "DEFAULT-VALUED PARAMETER CAUSED " &
+ "CONFUSION");
+ END IF;
+
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+END C95095E;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c951001.a b/gcc/testsuite/ada/acats/tests/c9/c951001.a
new file mode 100644
index 000000000..c1cf96593
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c951001.a
@@ -0,0 +1,192 @@
+-- C951001.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that two procedures in a protected object will not be
+-- executed concurrently.
+--
+-- TEST DESCRIPTION:
+-- A very simple example of two tasks calling two procedures in the same
+-- protected object is used. Test control code has been added to the
+-- procedures such that, whichever gets called first executes a lengthy
+-- calculation giving sufficient time (on a multiprocessor or a
+-- time-slicing machine) for the other task to get control and call the
+-- other procedure. The control code verifies that entry to the second
+-- routine is postponed until the first is complete.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C951001 is
+
+ protected Ramp_31 is
+
+ procedure Add_Meter_Queue;
+ procedure Subtract_Meter_Queue;
+ function TC_Failed return Boolean;
+
+ private
+
+ Ramp_Count : integer range 0..20 := 4; -- Start test with some
+ -- vehicles on the ramp
+
+ TC_Add_Started : Boolean := false;
+ TC_Subtract_Started : Boolean := false;
+ TC_Add_Finished : Boolean := false;
+ TC_Subtract_Finished : Boolean := false;
+ TC_Concurrent_Running: Boolean := false;
+
+ end Ramp_31;
+
+
+ protected body Ramp_31 is
+
+ function TC_Failed return Boolean is
+ begin
+ -- this indicator will have been set true if any instance
+ -- of concurrent running has been proved
+ return TC_Concurrent_Running;
+ end TC_Failed;
+
+
+ procedure Add_Meter_Queue is
+ begin
+ --==================================================
+ -- This section is all Test_Control code
+ TC_Add_Started := true;
+ if TC_Subtract_Started then
+ if not TC_Subtract_Finished then
+ TC_Concurrent_Running := true;
+ end if;
+ else
+ -- Subtract has not started.
+ -- Execute a lengthy routine to give it a chance to do so
+ ImpDef.Exceed_Time_Slice;
+
+ if TC_Subtract_Started then
+ -- Subtract was able to start so we have concurrent
+ -- running and the test has failed
+ TC_Concurrent_Running := true;
+ end if;
+ end if;
+ TC_Add_Finished := true;
+ --==================================================
+ Ramp_Count := Ramp_Count + 1;
+ end Add_Meter_Queue;
+
+ procedure Subtract_Meter_Queue is
+ begin
+ --==================================================
+ -- This section is all Test_Control code
+ TC_Subtract_Started := true;
+ if TC_Add_Started then
+ if not TC_Add_Finished then
+ -- We already have concurrent running
+ TC_Concurrent_Running := true;
+ end if;
+ else
+ -- Add has not started.
+ -- Execute a lengthy routine to give it a chance to do so
+ ImpDef.Exceed_Time_Slice;
+
+ if TC_Add_Started then
+ -- Add was able to start so we have concurrent
+ -- running and the test has failed
+ TC_Concurrent_Running := true;
+ end if;
+ end if;
+ TC_Subtract_Finished := true;
+ --==================================================
+ Ramp_Count := Ramp_Count - 1;
+ end Subtract_Meter_Queue;
+
+ end Ramp_31;
+
+begin
+
+ Report.Test ("C951001", "Check that two procedures in a protected" &
+ " object will not be executed concurrently");
+
+ declare -- encapsulate the test
+
+ task Vehicle_1;
+ task Vehicle_2;
+
+
+ -- Vehicle_1 and Vehicle_2 are simulations of Instances of the task
+ -- of type Vehicle in different stages of execution
+
+ task body Vehicle_1 is
+ begin
+ null; -- ::::: stub. preparation code
+
+ -- Add to the count of vehicles on the queue
+ Ramp_31.Add_Meter_Queue;
+
+ null; -- ::::: stub: wait at the meter then pass to first sensor
+
+ -- Reduce the count of vehicles on the queue
+ null; -- ::::: stub: Ramp_31.Subtract_Meter_Queue
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Vehicle_1 task");
+ end Vehicle_1;
+
+
+ task body Vehicle_2 is
+ begin
+ null; -- ::::: stub. preparation code
+
+ -- Add to the count of vehicles on the queue
+ null; -- ::::: stub Ramp_31.Add_Meter_Queue;
+
+ null; -- ::::: stub: wait at the meter then pass to first sensor
+
+ -- Reduce the count of vehicles on the queue
+ Ramp_31.Subtract_Meter_Queue;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Vehicle_2 task");
+ end Vehicle_2;
+
+
+
+ begin
+ null;
+ end; -- encapsulation
+
+ if Ramp_31.TC_Failed then
+ Report.Failed ("Concurrent Running detected");
+ end if;
+
+ Report.Result;
+
+end C951001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c951002.a b/gcc/testsuite/ada/acats/tests/c9/c951002.a
new file mode 100644
index 000000000..65b696c4a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c951002.a
@@ -0,0 +1,334 @@
+-- C951002.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that an entry and a procedure within the same protected object
+-- will not be executed simultaneously.
+--
+-- TEST DESCRIPTION:
+-- Two tasks are used. The first calls an entry who's barrier is set
+-- and is thus queued. The second calls a procedure in the same
+-- protected object. This procedure clears the entry barrier of the
+-- first then executes a lengthy compute bound procedure. This is
+-- intended to allow a multiprocessor, or a time-slicing implementation
+-- of a uniprocessor, to (erroneously) permit the first task to continue
+-- while the second is still computing. Flags in each process in the
+-- PO are checked to ensure that they do not run out of sequence or in
+-- parallel.
+-- In the second part of the test another entry and procedure are used
+-- but in this case the procedure is started first. A different task
+-- calls the entry AFTER the procedure has started. If the entry
+-- completes before the procedure the test fails.
+--
+-- This test will not be effective on a uniprocessor without time-slicing
+-- It is designed to increase the chances of failure on a multiprocessor,
+-- or a uniprocessor with time-slicing, if the entry and procedure in a
+-- Protected Object are not forced to acquire a single execution
+-- resource. It is not guaranteed to fail.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C951002 is
+
+ -- These global error flags are used for failure conditions within
+ -- the protected object. We cannot call Report.Failed (thus Text_io)
+ -- which would result in a bounded error.
+ --
+ TC_Error_01 : Boolean := false;
+ TC_Error_02 : Boolean := false;
+ TC_Error_03 : Boolean := false;
+ TC_Error_04 : Boolean := false;
+ TC_Error_05 : Boolean := false;
+ TC_Error_06 : Boolean := false;
+
+begin
+
+ Report.Test ("C951002", "Check that a procedure and an entry body " &
+ "in a protected object will not run concurrently");
+
+ declare -- encapsulate the test
+
+ task Credit_Message is
+ entry TC_Start;
+ end Credit_Message;
+
+ task Credit_Task is
+ entry TC_Start;
+ end Credit_Task;
+
+ task Debit_Message is
+ entry TC_Start;
+ end Debit_Message;
+
+ task Debit_Task is
+ entry TC_Start;
+ end Debit_Task;
+
+ --====================================
+
+ protected Hold is
+
+ entry Wait_for_CR_Underload;
+ procedure Clear_CR_Overload;
+ entry Wait_for_DB_Underload;
+ procedure Set_DB_Overload;
+ procedure Clear_DB_Overload;
+ --
+ function TC_Message_is_Queued return Boolean;
+
+ private
+ Credit_Overloaded : Boolean := true; -- Test starts in overload
+ Debit_Overloaded : Boolean := false;
+ --
+ TC_CR_Proc_Finished : Boolean := false;
+ TC_CR_Entry_Finished : Boolean := false;
+ TC_DB_Proc_Finished : Boolean := false;
+ TC_DB_Entry_Finished : Boolean := false;
+ end Hold;
+ --====================
+ protected body Hold is
+
+ entry Wait_for_CR_Underload when not Credit_Overloaded is
+ begin
+ -- The barrier must only be re-evaluated at the end of the
+ -- of the execution of the procedure, also while the procedure
+ -- is executing this entry body must not be executed
+ if not TC_CR_Proc_Finished then
+ TC_Error_01 := true; -- Set error indicator
+ end if;
+ TC_CR_Entry_Finished := true;
+ end Wait_for_CR_Underload ;
+
+ -- This is the procedure which should NOT be able to run in
+ -- parallel with the entry body
+ --
+ procedure Clear_CR_Overload is
+ begin
+
+ -- The entry body must not be executed until this procedure
+ -- is completed.
+ if TC_CR_Entry_Finished then
+ TC_Error_02 := true; -- Set error indicator
+ end if;
+ Credit_Overloaded := false; -- clear the entry barrier
+
+ -- Execute an implementation defined compute bound routine which
+ -- is designed to run long enough to allow a task switch on a
+ -- time-sliced uniprocessor, or for a multiprocessor to pick up
+ -- another task.
+ --
+ ImpDef.Exceed_Time_Slice;
+
+ -- Again, the entry body must not be executed until the current
+ -- procedure is completed.
+ --
+ if TC_CR_Entry_Finished then
+ TC_Error_03 := true; -- Set error indicator
+ end if;
+ TC_CR_Proc_Finished := true;
+
+ end Clear_CR_Overload;
+
+ --============
+ -- The following subprogram and entry body are used in the second
+ -- part of the test
+
+ entry Wait_for_DB_Underload when not Debit_Overloaded is
+ begin
+ -- By the time the task that calls this entry is allowed access to
+ -- the queue the barrier, which starts off as open, will be closed
+ -- by the Set_DB_Overload procedure. It is only reopened
+ -- at the end of the test
+ if not TC_DB_Proc_Finished then
+ TC_Error_04 := true; -- Set error indicator
+ end if;
+ TC_DB_Entry_Finished := true;
+ end Wait_for_DB_Underload ;
+
+
+ procedure Set_DB_Overload is
+ begin
+ -- The task timing is such that this procedure should be started
+ -- before the entry is called. Thus the entry should be blocked
+ -- until the end of this procedure which then sets the barrier
+ --
+ if TC_DB_Entry_Finished then
+ TC_Error_05 := true; -- Set error indicator
+ end if;
+
+ -- Execute an implementation defined compute bound routine which
+ -- is designed to run long enough to allow a task switch on a
+ -- time-sliced uniprocessor, or for a multiprocessor to pick up
+ -- another task
+ --
+ ImpDef.Exceed_Time_Slice;
+
+ Debit_Overloaded := true; -- set the entry barrier
+
+ if TC_DB_Entry_Finished then
+ TC_Error_06 := true; -- Set error indicator
+ end if;
+ TC_DB_Proc_Finished := true;
+
+ end Set_DB_Overload;
+
+ procedure Clear_DB_Overload is
+ begin
+ Debit_Overloaded := false; -- open the entry barrier
+ end Clear_DB_Overload;
+
+ function TC_Message_is_Queued return Boolean is
+ begin
+
+ -- returns true when one message arrives on the queue
+ return (Wait_for_CR_Underload'Count = 1);
+
+ end TC_Message_is_Queued ;
+
+ end Hold;
+
+ --====================================
+
+ task body Credit_Message is
+ begin
+ accept TC_Start;
+ --:: some application processing. Part of the process finds that
+ -- the Overload threshold has been exceeded for the Credit
+ -- application. This message task queues itself on a queue
+ -- waiting till the overload in no longer in effect
+ Hold.Wait_for_CR_Underload;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Credit_Message Task");
+ end Credit_Message;
+
+ task body Credit_Task is
+ begin
+ accept TC_Start;
+ -- Application code here (not shown) determines that the
+ -- underload threshold has been reached
+ Hold.Clear_CR_Overload;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Credit_Task");
+ end Credit_Task;
+
+ --==============
+
+ -- The following two tasks are used in the second part of the test
+
+ task body Debit_Message is
+ begin
+ accept TC_Start;
+ --:: some application processing. Part of the process finds that
+ -- the Overload threshold has been exceeded for the Debit
+ -- application. This message task queues itself on a queue
+ -- waiting till the overload is no longer in effect
+ --
+ Hold.Wait_for_DB_Underload;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Debit_Message Task");
+ end Debit_Message;
+
+ task body Debit_Task is
+ begin
+ accept TC_Start;
+ -- Application code here (not shown) determines that the
+ -- underload threshold has been reached
+ Hold.Set_DB_Overload;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Debit_Task");
+ end Debit_Task;
+
+ begin -- declare
+
+ Credit_Message.TC_Start;
+
+ -- Wait until the message is queued on the entry before starting
+ -- the Credit_Task
+ while not Hold.TC_Message_is_Queued loop
+ delay ImpDef.Long_Minimum_Task_Switch;
+ end loop;
+ --
+ Credit_Task.TC_Start;
+
+ -- Ensure the first part of the test is complete before continuing
+ while not (Credit_Message'terminated and Credit_Task'terminated) loop
+ delay ImpDef.Long_Minimum_Task_Switch;
+ end loop;
+
+ --======================================================
+ -- Second part of the test
+
+
+ Debit_Task.TC_Start;
+
+ -- Delay long enough to allow a task switch to the Debit_Task and
+ -- for it to reach the accept statement and call Hold.Set_DB_Overload
+ -- before starting Debit_Message
+ --
+ delay ImpDef.Long_Switch_To_New_Task;
+
+ Debit_Message.TC_Start;
+
+ while not Debit_Task'terminated loop
+ delay ImpDef.Long_Minimum_Task_Switch;
+ end loop;
+
+ Hold.Clear_DB_Overload; -- Allow completion
+
+ end; -- declare (encapsulation)
+
+ if TC_Error_01 then
+ Report.Failed ("Wait_for_CR_Underload executed out of sequence");
+ end if;
+ if TC_Error_02 then
+ Report.Failed ("Credit: Entry executed before procedure");
+ end if;
+ if TC_Error_03 then
+ Report.Failed ("Credit: Entry executed in parallel");
+ end if;
+ if TC_Error_04 then
+ Report.Failed ("Wait_for_DB_Underload executed out of sequence");
+ end if;
+ if TC_Error_05 then
+ Report.Failed ("Debit: Entry executed before procedure");
+ end if;
+ if TC_Error_06 then
+ Report.Failed ("Debit: Entry executed in parallel");
+ end if;
+
+ Report.Result;
+
+end C951002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953001.a b/gcc/testsuite/ada/acats/tests/c9/c953001.a
new file mode 100644
index 000000000..bc9c85f30
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c953001.a
@@ -0,0 +1,188 @@
+-- C953001.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if the evaluation of an entry_barrier condition
+-- propagates an exception, the exception Program_Error
+-- is propagated to all current callers of all entries of the
+-- protected object.
+--
+-- TEST DESCRIPTION:
+-- This test declares a protected object (PO) with two entries and
+-- a 5 element entry family.
+-- All the entries are always closed. However, one of the entries
+-- (Oh_No) will get a constraint_error in its barrier_evaluation
+-- whenever the global variable Blow_Up is true.
+-- An array of tasks is created where the tasks wait on the various
+-- entries of the protected object. Once all the tasks are waiting
+-- the main procedure calls the entry Oh_No and causes an exception
+-- to be propagated to all the tasks. The tasks record the fact
+-- that they got the correct exception in global variables that
+-- can be checked after the tasks complete.
+--
+--
+-- CHANGE HISTORY:
+-- 19 OCT 95 SAIC ACVC 2.1
+--
+--!
+
+
+with Report;
+with ImpDef;
+procedure C953001 is
+ Verbose : constant Boolean := False;
+ Max_Tasks : constant := 12;
+
+ -- note status and error conditions
+ Blocked_Entry_Taken : Boolean := False;
+ In_Oh_No : Boolean := False;
+ Task_Passed : array (1..Max_Tasks) of Boolean := (1..Max_Tasks => False);
+
+begin
+ Report.Test ("C953001",
+ "Check that an exception in an entry_barrier condition" &
+ " causes Program_Error to be propagated to all current" &
+ " callers of all entries of the protected object");
+
+ declare -- test encapsulation
+ -- miscellaneous values
+ Cows : Integer := Report.Ident_Int (1);
+ Came_Home : Integer := Report.Ident_Int (2);
+
+ -- make the Barrier_Condition fail only when we want it to
+ Blow_Up : Boolean := False;
+
+ function Barrier_Condition return Boolean is
+ begin
+ if Blow_Up then
+ return 5 mod Report.Ident_Int(0) = 1;
+ else
+ return False;
+ end if;
+ end Barrier_Condition;
+
+ subtype Family_Index is Integer range 1..5;
+
+ protected PO is
+ entry Block1;
+ entry Oh_No;
+ entry Family (Family_Index);
+ end PO;
+
+ protected body PO is
+ entry Block1 when Report.Ident_Int(0) = Report.Ident_Int(1) is
+ begin
+ Blocked_Entry_Taken := True;
+ end Block1;
+
+ -- barrier will get a Constraint_Error (divide by 0)
+ entry Oh_No when Barrier_Condition is
+ begin
+ In_Oh_No := True;
+ end Oh_No;
+
+ entry Family (for Member in Family_Index) when Cows = Came_Home is
+ begin
+ Blocked_Entry_Taken := True;
+ end Family;
+ end PO;
+
+
+ task type Waiter is
+ entry Take_Id (Id : Integer);
+ end Waiter;
+
+ Bunch_of_Waiters : array (1..Max_Tasks) of Waiter;
+
+ task body Waiter is
+ Me : Integer;
+ Action : Integer;
+ begin
+ accept Take_Id (Id : Integer) do
+ Me := Id;
+ end Take_Id;
+
+ Action := Me mod (Family_Index'Last + 1);
+ begin
+ if Action = 0 then
+ PO.Block1;
+ else
+ PO.Family (Action);
+ end if;
+ Report.Failed ("no exception for task" & Integer'Image (Me));
+ exception
+ when Program_Error =>
+ Task_Passed (Me) := True;
+ if Verbose then
+ Report.Comment ("pass for task" & Integer'Image (Me));
+ end if;
+ when others =>
+ Report.Failed ("wrong exception raised in task" &
+ Integer'Image (Me));
+ end;
+ end Waiter;
+
+
+ begin -- test encapsulation
+ for I in 1..Max_Tasks loop
+ Bunch_Of_Waiters(I).Take_Id (I);
+ end loop;
+
+ -- give all the Waiters time to get queued
+ delay 2*ImpDef.Clear_Ready_Queue;
+
+ -- cause the protected object to fail
+ begin
+ Blow_Up := True;
+ PO.Oh_No;
+ Report.Failed ("no exception in call to PO.Oh_No");
+ exception
+ when Constraint_Error =>
+ Report.Failed ("Constraint_Error instead of Program_Error");
+ when Program_Error =>
+ if Verbose then
+ Report.Comment ("main exception passed");
+ end if;
+ when others =>
+ Report.Failed ("wrong exception in main");
+ end;
+ end; -- test encapsulation
+
+ -- all the tasks have now completed.
+ -- check the flags for pass/fail info
+ if Blocked_Entry_Taken then
+ Report.Failed ("blocked entry taken");
+ end if;
+ if In_Oh_No then
+ Report.Failed ("entry taken with exception in barrier");
+ end if;
+ for I in 1..Max_Tasks loop
+ if not Task_Passed (I) then
+ Report.Failed ("task" & Integer'Image (I) & " did not pass");
+ end if;
+ end loop;
+
+ Report.Result;
+end C953001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953002.a b/gcc/testsuite/ada/acats/tests/c9/c953002.a
new file mode 100644
index 000000000..d821bb24e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c953002.a
@@ -0,0 +1,242 @@
+-- C953002.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the servicing of entry queues of a protected object
+-- continues until there are no open entries with queued calls
+-- and that this takes place as part of a single protected
+-- operation.
+--
+-- TEST DESCRIPTION:
+-- This test enqueues a bunch of tasks on the entries of the
+-- protected object Main_PO. At the same time another bunch of
+-- of tasks are queued on the single entry of protected object
+-- Holding_Pen.
+-- Once all the tasks have had time to block, the main procedure
+-- opens all the entries for Main_PO by calling the
+-- Start_Protected_Operation protected procedure. This should
+-- process all the pending callers as part of a single protected
+-- operation.
+-- During this protected operation, the entries of Main_PO release
+-- the tasks blocked on Holding_Pen by calling the protected
+-- procedure Release.
+-- Once released from Holding_Pen, the task immediately calls
+-- an entry in Main_PO.
+-- These new calls should not gain access to Main_PO until
+-- the initial protected operation on that object completes.
+-- The order in which the entry calls on Main_PO are taken is
+-- recorded in a global array and checked after all the tasks
+-- have terminated.
+--
+--
+-- CHANGE HISTORY:
+-- 25 OCT 95 SAIC ACVC 2.1
+-- 15 JAN 95 SAIC Fixed deadlock problem.
+--
+--!
+
+with Report;
+procedure C953002 is
+ Verbose : constant Boolean := False;
+
+ Half_Tasks : constant := 15; -- how many tasks of each group
+ Max_Tasks : constant := Half_Tasks * 2; -- total number of tasks
+
+ Note_Order : array (1..Max_Tasks) of Integer := (1..Max_Tasks => 0);
+ Note_Cnt : Integer := 0;
+begin
+ Report.Test ("C953002",
+ "Check that the servicing of entry queues handles all" &
+ " open entries as part of a single protected operation");
+ declare
+ task type Assault_PO is
+ entry Take_ID (Id : Integer);
+ end Assault_PO;
+
+ First_Wave : array (1 .. Half_Tasks) of Assault_PO;
+ Second_Wave : array (1 .. Half_Tasks) of Assault_PO;
+
+ protected Main_PO is
+ entry E0 (Who : Integer);
+ entry E1 (Who : Integer);
+ entry E2 (Who : Integer);
+ entry E3 (Who : Integer);
+ entry All_Present;
+ procedure Start_Protected_Operation;
+ private
+ Open : Boolean := False;
+ end Main_PO;
+
+ protected Holding_Pen is
+ -- Note that Release is called by tasks executing in
+ -- the protected object Main_PO.
+ entry Wait (Who : Integer);
+ entry All_Present;
+ procedure Release;
+ private
+ Open : Boolean := False;
+ end Holding_Pen;
+
+
+ protected body Main_PO is
+ procedure Start_Protected_Operation is
+ begin
+ Open := True;
+ -- at this point all the First_Wave tasks are
+ -- waiting at the entries and all of them should
+ -- be processed as part of the protected operation.
+ end Start_Protected_Operation;
+
+ entry All_Present when E0'Count + E1'Count + E2'Count + E3'Count =
+ Max_Tasks / 2 is
+ begin
+ null; -- all tasks are waiting
+ end All_Present;
+
+ entry E0 (Who : Integer) when Open is
+ begin
+ Holding_Pen.Release;
+ -- note the order in which entry calls are handled.
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ end E0;
+
+ entry E1 (Who : Integer) when Open is
+ begin
+ Holding_Pen.Release;
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ end E1;
+
+ entry E2 (Who : Integer) when Open is
+ begin
+ Holding_Pen.Release;
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ end E2;
+
+ entry E3 (Who : Integer) when Open is
+ begin
+ Holding_Pen.Release;
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ end E3;
+ end Main_PO;
+
+
+ protected body Holding_Pen is
+ procedure Release is
+ begin
+ Open := True;
+ end Release;
+
+ entry All_Present when Wait'Count = Max_Tasks / 2 is
+ begin
+ null; -- all tasks waiting
+ end All_Present;
+
+ entry Wait (Who : Integer) when Open is
+ begin
+ null; -- unblock the task
+ end Wait;
+ end Holding_Pen;
+
+ task body Assault_PO is
+ Me : Integer;
+ begin
+ accept Take_Id (Id : Integer) do
+ Me := Id;
+ end Take_Id;
+ if Me >= 200 then
+ Holding_Pen.Wait (Me);
+ end if;
+ case Me mod 4 is
+ when 0 => Main_PO.E0 (Me);
+ when 1 => Main_PO.E1 (Me);
+ when 2 => Main_PO.E2 (Me);
+ when 3 => Main_PO.E3 (Me);
+ when others => null; -- cant happen
+ end case;
+ if Verbose then
+ Report.Comment ("task" & Integer'Image (Me) &
+ " done");
+ end if;
+ exception
+ when others =>
+ Report.Failed ("exception in task");
+ end Assault_PO;
+
+ begin -- test encapsulation
+ for I in First_Wave'Range loop
+ First_Wave (I).Take_ID (100 + I);
+ end loop;
+ for I in Second_Wave'Range loop
+ Second_Wave (I).Take_ID (200 + I);
+ end loop;
+
+ -- let all the tasks get blocked
+ Main_PO.All_Present;
+ Holding_Pen.All_Present;
+
+ -- let the games begin
+ if Verbose then
+ Report.Comment ("starting protected operation");
+ end if;
+ Main_PO.Start_Protected_Operation;
+
+ -- wait for all the tasks to complete
+ if Verbose then
+ Report.Comment ("waiting for tasks to complete");
+ end if;
+ end;
+
+ -- make sure all tasks registered their order
+ if Note_Cnt /= Max_Tasks then
+ Report.Failed ("task registration count wrong. " &
+ Integer'Image (Note_Cnt));
+ end if;
+
+ -- check the order in which entries were handled.
+ -- all the 100 level items should be handled as part of the
+ -- first protected operation and thus should be completed
+ -- before any 200 level item.
+
+ if Verbose then
+ for I in 1..Max_Tasks loop
+ Report.Comment ("order" & Integer'Image (I) & " is" &
+ Integer'Image (Note_Order (I)));
+ end loop;
+ end if;
+ for I in 2 .. Max_Tasks loop
+ if Note_Order (I) < 200 and
+ Note_Order (I-1) >= 200 then
+ Report.Failed ("protected operation failure" &
+ Integer'Image (Note_Order (I-1)) &
+ Integer'Image (Note_Order (I)));
+ end if;
+ end loop;
+
+ Report.Result;
+end C953002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953003.a b/gcc/testsuite/ada/acats/tests/c9/c953003.a
new file mode 100644
index 000000000..4ac91169e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c953003.a
@@ -0,0 +1,189 @@
+-- C953003.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the servicing of entry queues of a protected object
+-- continues until there are no open entries with queued (or
+-- requeued) calls and that internal requeues are handled
+-- as part of a single protected operation.
+--
+-- TEST DESCRIPTION:
+-- A number of tasks are created and blocked on a protected object
+-- so that they can all be released at one time. When released,
+-- these tasks make an entry call to an entry in the Main_PO
+-- protected object. As part of the servicing of this entry
+-- call the call is passed through the remaining entries of the
+-- protected object by using internal requeues. The protected
+-- object checks that no other entry call is accepted until
+-- after all the internal requeuing has completed.
+--
+--
+-- CHANGE HISTORY:
+-- 12 JAN 96 SAIC Initial version for 2.1
+--
+--!
+
+with Report;
+procedure C953003 is
+ Verbose : constant Boolean := False;
+
+ Order_Error : Boolean := False;
+
+ Max_Tasks : constant := 10; -- total number of tasks
+ Max_Entries : constant := 4; -- number of entries in Main_PO
+ Note_Cnt : Integer := 0;
+ Note_Order : array (1..Max_Tasks*Max_Entries) of Integer;
+begin
+ Report.Test ("C953003",
+ "Check that the servicing of entry queues handles all" &
+ " open entries as part of a single protected operation," &
+ " including those resulting from an internal requeue");
+ declare
+ task type Assault_PO is
+ entry Take_ID (Id : Integer);
+ end Assault_PO;
+
+ Marines : array (1 .. Max_Tasks) of Assault_PO;
+
+ protected Main_PO is
+ entry E0 (Who : Integer);
+ private
+ entry E3 (Who : Integer);
+ entry E2 (Who : Integer);
+ entry E1 (Who : Integer);
+ Expected_Next : Integer := 0;
+ end Main_PO;
+
+
+ protected body Main_PO is
+
+ entry E0 (Who : Integer) when True is
+ begin
+ Order_Error := Order_Error or Expected_Next /= 0;
+ Expected_Next := 1;
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ requeue E1;
+ end E0;
+
+ entry E1 (Who : Integer) when True is
+ begin
+ Order_Error := Order_Error or Expected_Next /= 1;
+ Expected_Next := 2;
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ requeue E2;
+ end E1;
+
+ entry E3 (Who : Integer) when True is
+ begin
+ Order_Error := Order_Error or Expected_Next /= 3;
+ Expected_Next := 0;
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ -- all done - return now
+ end E3;
+
+ entry E2 (Who : Integer) when True is
+ begin
+ Order_Error := Order_Error or Expected_Next /= 2;
+ Expected_Next := 3;
+ Note_Cnt := Note_Cnt + 1;
+ Note_Order (Note_Cnt) := Who;
+ requeue E3;
+ end E2;
+ end Main_PO;
+
+ protected Holding_Pen is
+ entry Wait_For_All_Present;
+ entry Wait;
+ private
+ Open : Boolean := False;
+ end Holding_Pen;
+
+ protected body Holding_Pen is
+ entry Wait_For_All_Present when Wait'Count = Max_Tasks is
+ begin
+ Open := True;
+ end Wait_For_All_Present;
+
+ entry Wait when Open is
+ begin
+ null; -- just go
+ end Wait;
+ end Holding_Pen;
+
+
+ task body Assault_PO is
+ Me : Integer;
+ begin
+ accept Take_Id (Id : Integer) do
+ Me := Id;
+ end Take_Id;
+ Holding_Pen.Wait;
+ Main_PO.E0 (Me);
+ if Verbose then
+ Report.Comment ("task" & Integer'Image (Me) &
+ " done");
+ end if;
+ exception
+ when others =>
+ Report.Failed ("exception in task");
+ end Assault_PO;
+
+ begin -- test encapsulation
+ for I in Marines'Range loop
+ Marines (I).Take_ID (100 + I);
+ end loop;
+
+ -- let all the tasks get blocked so we can release them all
+ -- at one time
+ Holding_Pen.Wait_For_All_Present;
+
+ -- wait for all the tasks to complete
+ if Verbose then
+ Report.Comment ("waiting for tasks to complete");
+ end if;
+ end;
+
+ -- make sure all tasks registered their order
+ if Note_Cnt /= Max_Tasks * Max_Entries then
+ Report.Failed ("task registration count wrong. " &
+ Integer'Image (Note_Cnt));
+ end if;
+
+ if Order_Error then
+ Report.Failed ("internal requeue not handled as part of operation");
+ end if;
+
+ if Verbose or Order_Error then
+ for I in 1..Max_Tasks * Max_Entries loop
+ Report.Comment ("order" & Integer'Image (I) & " is" &
+ Integer'Image (Note_Order (I)));
+ end loop;
+ end if;
+
+ Report.Result;
+end C953003;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954001.a b/gcc/testsuite/ada/acats/tests/c9/c954001.a
new file mode 100644
index 000000000..3112cce2b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954001.a
@@ -0,0 +1,273 @@
+-- C954001.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue statement within an entry_body with parameters
+-- may requeue the entry call to a protected entry with a subtype-
+-- conformant parameter profile. Check that, if the call is queued on the
+-- new entry's queue, the original caller remains blocked after the
+-- requeue, but the entry_body containing the requeue is completed.
+--
+-- TEST DESCRIPTION:
+-- Declare a protected object which simulates a disk device. Declare an
+-- entry that requeues the caller to a second entry if the disk head is
+-- not in the proper location, but first sets the second entry's barrier
+-- to false. Declare a procedure which sets the second entry's barrier
+-- to true.
+--
+-- Declare a task which calls the first entry such that the requeue is
+-- called. This task should be queued on the second entry and remain
+-- blocked, and the first entry should be complete. Call the procedure
+-- which releases the second entry's queue. The second entry should
+-- complete, after which the task should complete.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+package C954001_0 is -- Disk management abstraction.
+
+
+ -- Simulate a read-only disk device with a head that may be moved to
+ -- different tracks. If a read request is issued for the current
+ -- track, the request can be satisfied immediately. Otherwise, the head
+ -- must be moved to the correct track, during which time the calling task
+ -- is blocked. When the head reaches the correct track, the disk generates
+ -- an interrupt, after which the request can be satisfied, and the
+ -- calling task can proceed.
+
+ Buffer_Size : constant := 100;
+
+ type Disk_Buffer is new String (1 .. Buffer_Size);
+ type Disk_Track is new Natural;
+
+ type Disk_Address is record
+ Track : Disk_Track;
+ -- Additional components.
+ end record;
+
+ Initial_Track : constant Disk_Track := 0;
+ New_Track : constant Disk_Track := 5;
+
+ --==============================================--
+
+ protected Disk_Device is
+
+ entry Read (Where : Disk_Address; -- Read data from disk
+ Data : out Disk_Buffer); -- track.
+
+ procedure Disk_Interrupt; -- Handle interrupt
+ -- from disk.
+
+ function TC_Track return Disk_Track; -- Return current track.
+
+ function TC_Pending_Queued return Boolean; -- True when there is
+ -- an entry in queue
+
+ private
+
+ entry Pending_Read (Where : Disk_Address; -- Wait for head to
+ Data : out Disk_Buffer); -- move then read data.
+
+ Current_Track : Disk_Track := Initial_Track; -- Current disk track.
+ Operation_Pending : Boolean := False; -- Vis. entry barrier.
+ Disk_Interrupted : Boolean := False; -- Priv. entry barrier.
+
+ end Disk_Device;
+
+
+end C954001_0;
+
+
+ --==================================================================--
+
+
+package body C954001_0 is -- Disk management abstraction.
+
+
+ protected body Disk_Device is
+
+ entry Read (Where : Disk_Address; Data : out Disk_Buffer)
+ when not Operation_Pending is
+ begin
+ if (Where.Track = Current_Track) then -- If the head is over the
+ -- Read data from disk... -- requested track, read
+ null; -- the data.
+
+ else -- Otherwise, defer read
+ Operation_Pending := True; -- while head is moved to
+ -- correct track (signaled
+ -- -- -- by a disk interrupt).
+ -- Requeue is tested here --
+ -- --
+
+ requeue Pending_Read;
+
+ end if;
+ end Read;
+
+
+ procedure Disk_Interrupt is -- Called when the disk
+ begin -- interrupts, indicating
+ Disk_Interrupted := True; -- that the head is over
+ end Disk_Interrupt; -- the correct track.
+
+
+ function TC_Track return Disk_Track is -- Artifice required for
+ begin -- testing purposes.
+ return (Current_Track);
+ end TC_Track;
+
+
+ entry Pending_Read (Where : Disk_Address; Data : out Disk_Buffer)
+ when Disk_Interrupted is
+ begin
+ Current_Track := Where.Track; -- Head is now over the
+ -- Read data from disk... -- correct track; read
+ Operation_Pending := False; -- the data.
+ Disk_Interrupted := False;
+ end Pending_Read;
+
+ function TC_Pending_Queued return Boolean is
+ begin
+ -- Return true when there is something on the Pending_Read queue
+ return (Pending_Read'Count /=0);
+ end TC_Pending_Queued;
+
+ end Disk_Device;
+
+
+end C954001_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with C954001_0; -- Disk management abstraction.
+use C954001_0;
+
+procedure C954001 is
+
+
+ task type Read_Task is -- an unusual (but legal) declaration
+ end Read_Task;
+ --
+ --
+ task body Read_Task is
+ Location : constant Disk_Address := (Track => New_Track);
+ Data : Disk_Buffer := (others => ' ');
+ begin
+ Disk_Device.Read (Location, Data); -- Invoke requeue statement.
+ exception
+ when others =>
+ Report.Failed ("Exception raised in task");
+ end Read_Task;
+
+ --==============================================--
+
+begin -- Main program.
+
+ Report.Test ("C954001", "Requeue from an entry within a P.O. " &
+ "to a private entry within the same P.O.");
+
+
+ declare
+
+ IO_Request : Read_Task; -- Request a read from other
+ -- than the current track.
+ -- IO_Request will be requeued
+ -- from Read to Pending_Read.
+ begin
+
+ -- To pass this test, the following must be true:
+ --
+ -- (A) The Read entry call made by the task IO_Request must be
+ -- completed by the requeue.
+ -- (B) IO_Request must remain blocked following the requeue.
+ -- (C) IO_Request must be queued on the Pending_Read entry queue.
+ -- (D) IO_Request must continue execution after the Pending_Read
+ -- entry completes.
+ --
+ -- First, verify (A): that the Read entry call is complete.
+ --
+ -- Call a protected operation (Disk_Device.TC_Track). Since no two
+ -- protected actions may proceed concurrently unless both are protected
+ -- function calls, a call to a protected operation at this point can
+ -- proceed only if the Read entry call is already complete.
+ --
+ -- Note that if Read is NOT complete, the test will likely hang here.
+ --
+ -- Next, verify (B): that IO_Request remains blocked following the
+ -- requeue. Also verify that Pending_Read (the entry to which
+ -- IO_Request should have been queued) has not yet executed.
+
+ -- Wait until the task had made the call and the requeue has been
+ -- effected.
+ while not Disk_Device.TC_Pending_Queued loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ if Disk_Device.TC_Track /= Initial_Track then
+ Report.Failed ("Target entry of requeue executed prematurely");
+ elsif IO_Request'Terminated then
+ Report.Failed ("Caller did not remain blocked after " &
+ "the requeue or was never requeued");
+ else
+
+ -- Verify (C): that IO_Request is queued on the
+ -- Pending_Read entry queue.
+ --
+ -- Set the barrier for Pending_Read to true. Check that the
+ -- current track is updated and that IO_Request terminates.
+
+ Disk_Device.Disk_Interrupt; -- Simulate a disk interrupt,
+ -- signaling that the head is
+ -- over the correct track.
+
+ -- The Pending_Read entry body will complete before the next
+ -- protected action is called (Disk_Device.TC_Track).
+
+ if Disk_Device.TC_Track /= New_Track then
+ Report.Failed ("Caller was not requeued on target entry");
+ end if;
+
+ -- Finally, verify (D): that Read_Task continues after Pending_Read
+ -- completes.
+ --
+ -- Note that the test will hang here if Read_Task does not continue
+ -- executing following the completion of the requeued entry call.
+
+ end if;
+
+ end; -- We will not exit the declare block until the task completes
+
+ Report.Result;
+
+end C954001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954010.a b/gcc/testsuite/ada/acats/tests/c9/c954010.a
new file mode 100644
index 000000000..ac39c89a8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954010.a
@@ -0,0 +1,286 @@
+-- C954010.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue within an accept statement does not block.
+-- This test uses: Requeue to an entry in a different task
+-- Parameterless call
+-- Requeue with abort
+--
+-- TEST DESCRIPTION:
+-- In the Distributor task, requeue two successive calls on the entries
+-- of two separate target tasks. Verify that the target tasks are
+-- run in parallel proving that the first requeue does not block
+-- while the first target rendezvous takes place.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life,
+-- dynamic and unpredictable at the time of message generation. All
+-- rerouting in this model is done by means of requeues.
+--
+-- This test is directed towards the BLOCKING of the REQUEUE only
+-- If the original caller does not block, the outcome of the test will
+-- not be affected. If the original caller does not continue after
+-- the return, the test will not pass.
+-- If the requeue gets placed on the wrong entry a failing test could
+-- pass (eg. if the first message is delivered to the second
+-- computation task and the second message to the first) - a check for
+-- this condition is made in other tests
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954010 is
+
+ -- Mechanism to count the number of Message tasks completed
+ protected TC_Tasks_Completed is
+ procedure Increment;
+ function Count return integer;
+ private
+ Number_Complete : integer := 0;
+ end TC_Tasks_Completed;
+ --
+ TC_Expected_To_Complete : constant integer := 2;
+
+
+ task type Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ task Distributor is
+ entry Input;
+ end Distributor;
+
+ task Credit_Computation is
+ entry Input;
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input;
+ entry TC_Artificial_Rendezvous_1; -- test purposes only
+ entry TC_Artificial_Rendezvous_2; -- test purposes only
+ end Debit_Computation;
+
+
+ -- Mechanism to count the number of Message tasks completed
+ protected body TC_Tasks_Completed is
+ procedure Increment is
+ begin
+ Number_Complete := Number_Complete + 1;
+ end Increment;
+
+ function Count return integer is
+ begin
+ return Number_Complete;
+ end Count;
+ end TC_Tasks_Completed;
+
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each and sends this to a Distributor
+ -- for appropriate disposal around the network of tasks
+ -- Such a task would normally be designed to loop continuously
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to two dummy messages for this test and allow it
+ -- to terminate at that point
+ --
+ task body Line_Driver is
+
+ begin
+
+ accept Start; -- Wait for trigger from main
+
+ for i in 1..2 loop
+ declare
+ -- create a new message task
+ N : acc_Message_Task := new Message_Task;
+ begin
+ -- preparation code
+ null; -- stub
+
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+ task body Message_Task is
+ begin
+ -- Queue up on Distributor's Input queue
+ Distributor.Input;
+
+ -- After the required computations have been performed
+ -- return the message appropriately (probably to an output
+ -- line driver
+ null; -- stub
+
+ -- Increment to show completion of this task
+ TC_Tasks_Completed.Increment;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+ -- Dispose each input message to the appropriate computation tasks
+ -- Normally this would be according to some parameters in the entry
+ -- but this simple test is using parameterless entries.
+ --
+ task body Distributor is
+ Last_was_for_Credit_Computation : Boolean := false; -- switch
+ begin
+ loop
+ select
+ accept Input do
+ -- Determine to which task the message should be
+ -- distributed
+ -- For this test arbitrarily send the first to
+ -- Credit_Computation and the second to Debit_Computation
+ if Last_was_for_Credit_Computation then
+ requeue Debit_Computation.Input with abort;
+ else
+ Last_was_for_Credit_Computation := true;
+ requeue Credit_Computation.Input with abort;
+ end if;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Distributor");
+ end Distributor;
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ task body Credit_Computation is
+ begin
+ loop
+ select
+ accept Input do
+ -- Perform the computations required for this message
+ --
+ null; -- stub
+
+ -- For the test:
+ -- Artificially rendezvous with Debit_Computation.
+ -- If the first requeue in Distributor has blocked
+ -- waiting for the current rendezvous to complete then the
+ -- second message will not be sent to Debit_Computation
+ -- which will still be waiting on its Input accept.
+ -- This task will HANG
+ --
+ Debit_Computation.TC_Artificial_Rendezvous_1;
+ --
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ TC_AR1_is_complete : Boolean := false;
+ begin
+ loop
+ select
+ accept Input do
+ -- Perform the computations required for this message
+ null; -- stub
+ end Input;
+ Message_Count := Message_Count + 1;
+ or
+ -- Guard until the rendezvous with the message for this task
+ -- has completed
+ when Message_Count > 0 =>
+ accept TC_Artificial_Rendezvous_1; -- see comments in
+ -- Credit_Computation above
+ TC_AR1_is_complete := true;
+ or
+ -- Completion rendezvous with the main procedure
+ when TC_AR1_is_complete =>
+ accept TC_Artificial_Rendezvous_2;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+
+ end Debit_Computation;
+
+
+begin -- c954010
+ Report.Test ("C954010", "Requeue in an accept body does not block");
+
+ Line_Driver.Start;
+
+ -- Ensure that both messages were delivered to the computation tasks
+ -- This shows that both requeues were effective.
+ --
+ Debit_Computation.TC_Artificial_Rendezvous_2;
+
+ -- Ensure that the message tasks completed
+ while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954010;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954011.a b/gcc/testsuite/ada/acats/tests/c9/c954011.a
new file mode 100644
index 000000000..159b32dba
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954011.a
@@ -0,0 +1,384 @@
+-- C954011.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue is placed on the correct entry; that the
+-- original caller waits for the completion of the requeued rendezvous;
+-- that the original caller continues after the rendezvous.
+-- Specifically, this test checks requeue to an entry in a different
+-- task, requeue where the entry has parameters, and requeue with
+-- abort.
+--
+-- TEST DESCRIPTION:
+-- In the Distributor task, requeue two successive calls on the entries
+-- of two separate target tasks. Each task in each of the paths adds
+-- identifying information in the transaction being passed. This
+-- information is checked by the Message tasks on completion ensuring that
+-- the requeues have been placed on the correct queues.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life,
+-- dynamic and unpredictable at the time of message generation. All
+-- rerouting in this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 26 Nov 95 SAIC Fixed problems with shared global variables
+-- for ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954011 is
+
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+ type Transaction_Code is (Credit, Debit);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Distrib : Boolean := false;
+ end record;
+
+ protected type Message_Mgr is
+ procedure Mark_Complete;
+ function Is_Complete return Boolean;
+ private
+ Complete : Boolean := False;
+ end Message_Mgr;
+
+ protected body Message_Mgr is
+ procedure Mark_Complete is
+ begin
+ Complete := True;
+ end Mark_Complete;
+
+ Function Is_Complete return Boolean is
+ begin
+ return Complete;
+ end Is_Complete;
+ end Message_Mgr;
+
+ TC_Debit_Message : Message_Mgr;
+ TC_Credit_Message : Message_Mgr;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ task Distributor is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Distributor;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- The Line Driver task would normally be designed to loop continuously
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to two dummy messages for this test and allow it
+ -- to terminate at that point
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ TC_Last_was_for_credit : Boolean := false;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ accept Start; -- Wait for trigger from Main
+
+ for i in 1..2 loop -- arbitrarily limit to two messages for the test
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record
+ := new Transaction_Record;
+ begin
+ if TC_Last_was_for_credit then
+ Build_Debit_Record ( Next_Transaction );
+ else
+ Build_Credit_Record( Next_Transaction );
+ TC_Last_was_for_credit := true;
+ end if;
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+ accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+
+ -- The following is all Test Control Code
+
+ -- Check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= Credit_Return or
+ This_Transaction.TC_Message_Count /= 1 or not
+ This_Transaction.TC_Thru_Distrib then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Credit_Message.Mark_Complete;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or not
+ This_Transaction.TC_Thru_Distrib then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Debit_Message.Mark_Complete;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ task body Distributor is
+
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Mark the message as having passed through the distributor
+ Transaction.TC_Thru_Distrib := true;
+
+ -- Pass this transaction on the appropriate computation
+ -- task
+ case Transaction.Code is
+ when Credit =>
+ requeue Credit_Computation.Input with abort;
+ when Debit =>
+ requeue Debit_Computation.Input with abort;
+ end case;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Distributor");
+ end Distributor;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ --
+ task body Credit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input ( Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this transaction
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_Thru_Distrib then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Credit_Return;
+ -- one, and only one message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ --
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_Thru_Distrib then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+
+ end Debit_Computation;
+
+
+begin -- c954011
+
+ Report.Test ("C954011", "Requeue from task body to task entry");
+
+ Line_Driver.Start; -- Start the test
+
+ -- Ensure that the message tasks complete before reporting the result
+ while not (TC_Credit_Message.Is_Complete and
+ TC_Debit_Message.Is_Complete) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954011;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954012.a b/gcc/testsuite/ada/acats/tests/c9/c954012.a
new file mode 100644
index 000000000..44575b1b1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954012.a
@@ -0,0 +1,496 @@
+-- C954012.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check a requeue within an accept body to another entry in the same task
+-- Specifically, check a call with parameters and a requeue with abort.
+--
+-- TEST DESCRIPTION:
+-- One transaction is sent through to check the paths. After
+-- processing this the Credit task sets the "overloaded" indicator. Once
+-- this indicator is set the Distributor queues low priority transactions
+-- on a Wait_for_Underload queue in the same task using a requeue. The
+-- Distributor still delivers high priority transactions. After two high
+-- priority transactions have been processed by the Credit task it clears
+-- the overload condition. The low priority transactions should now be
+-- delivered.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life, dynamic
+-- and unpredictable at the time of message generation. All rerouting in
+-- this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 25 Nov 95 SAIC Fixed shared global variable problem for
+-- ACVC 2.0.1
+-- 14 Mar 03 RLB Fixed a race condition and an incorrect termination
+-- condition in the test.
+--!
+
+with Report;
+with ImpDef;
+with Ada.Calendar;
+
+procedure C954012 is
+
+ function "=" (X,Y: Ada.Calendar.Time) return Boolean
+ renames Ada.Calendar."=";
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+
+ -- This is used as an "initializing" time for the messages as they are
+ -- created. As they pass through the Distributor they get a time_stamp
+ -- of the current time. An arbitrary base time is chosen.
+ -- TC: this fact is used, incidentally, to check that the messages have,
+ -- indeed, passed through the Distributor as expected.
+ --
+ Base_Time : Ada.Calendar.Time := Ada.Calendar.Time_of(1959,3,9);
+
+
+ -- Mechanism to count the number of Credit Message tasks completed
+ protected TC_Tasks_Completed is
+ procedure Increment;
+ function Count return integer;
+ private
+ Number_Complete : integer := 0;
+ end TC_Tasks_Completed;
+
+ protected type Shared_Boolean (Initial_Value : Boolean := False) is
+ procedure Set_True;
+ procedure Set_False;
+ function Value return Boolean;
+ private
+ Current_Value : Boolean := Initial_Value;
+ end Shared_Boolean;
+
+ protected body Shared_Boolean is
+ procedure Set_True is
+ begin
+ Current_Value := True;
+ end Set_True;
+
+ procedure Set_False is
+ begin
+ Current_Value := False;
+ end Set_False;
+
+ function Value return Boolean is
+ begin
+ return Current_Value;
+ end Value;
+ end Shared_Boolean;
+
+ TC_Debit_Message_Complete : Shared_Boolean (False);
+ -- Handshaking mechanism between the Line Driver and the Credit task
+ TC_First_Message_Has_Arrived : Shared_Boolean (False);
+ Credit_Overloaded : Shared_Boolean (False);
+
+ TC_Credit_Messages_Expected : constant integer := 5;
+
+ type Transaction_Code is (Credit, Debit);
+ type Transaction_Priority is (High, Low);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Priority : Transaction_Priority := High;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ Message_Count : integer := 0; -- for test
+ Time_Stamp : Ada.Calendar.Time := Base_Time;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ task Distributor is
+ entry Input (Transaction : acc_Transaction_Record);
+ entry Wait_for_Underload (Transaction : acc_Transaction_Record);
+ entry TC_Credit_OK;
+ end Distributor;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+
+ -- Mechanism to count the number of Message tasks completed (Credit)
+ protected body TC_Tasks_Completed is
+ procedure Increment is
+ begin
+ Number_Complete := Number_Complete + 1;
+ end Increment;
+
+ function Count return integer is
+ begin
+ return Number_Complete;
+ end Count;
+ end TC_Tasks_Completed;
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- The Line Driver task would normally be designed to loop continuously
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to the required number of dummy messages needed for
+ -- this test and allow it to terminate at that point. Artificially
+ -- alternate High and Low priority Credit transactions for this test.
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ Current_Priority : Transaction_Priority := High;
+
+ -- Artificial: number of messages required for this test
+ type TC_Trans_Range is range 1..6;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+ Next_Transaction.Priority := Current_Priority;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ accept Start; -- Wait for trigger from Main
+
+ for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record
+ := new Transaction_Record;
+ begin
+ if Transaction_Numb = TC_Trans_Range'first then
+ -- Send the first Credit message
+ Build_Credit_Record ( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ -- TC: Wait until the first message has been received by the
+ -- Credit task and it has set the Overload indicator for the
+ -- Distributor
+ while not TC_First_Message_Has_Arrived.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ elsif Transaction_Numb = TC_Trans_Range'last then
+ -- For this test send the last transaction to the Debit task
+ -- to improve the mix
+ Build_Debit_Record( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ else
+ -- TC: Alternate high and low priority transactions
+ if Current_Priority = High then
+ Current_Priority := Low;
+ else
+ Current_Priority := High;
+ end if;
+ Build_Credit_Record( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end if;
+ end; -- declare
+ end loop;
+
+ -- TC: Wait for Credit_Overloaded to be cleared, then insure that the
+ -- Distributor has evalated all tasks. Otherwise, some tasks may never
+ -- be evaluated.
+ while Credit_Overloaded.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ Distributor.TC_Credit_OK;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+
+ accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+ -- For the test check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= Credit_Return or
+ This_Transaction.Time_Stamp = Base_Time then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Tasks_Completed.Increment;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.Message_Count /= 1 or
+ This_Transaction.Time_Stamp = Base_Time then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Debit_Message_Complete.Set_True;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+
+
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ task body Distributor is
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Time_Stamp the messages with the current time
+ -- TC: Used, incidentally, by the test to check that the
+ -- message did pass through the Distributor Task
+ Transaction.Time_Stamp := Ada.Calendar.Clock;
+
+ -- Pass this transaction on to the appropriate computation
+ -- task but temporarily hold low-priority transactions under
+ -- overload conditions
+ case Transaction.Code is
+ when Credit =>
+ if Credit_Overloaded.Value and
+ Transaction.Priority = Low then
+ requeue Wait_for_Underload with abort;
+ else
+ requeue Credit_Computation.Input with abort;
+ end if;
+ when Debit =>
+ requeue Debit_Computation.Input with abort;
+ end case;
+ end Input;
+ or
+ when not Credit_Overloaded.Value =>
+ accept Wait_for_Underload (Transaction : acc_Transaction_Record) do
+ requeue Credit_Computation.Input with abort;
+ end Wait_for_Underload;
+ or
+ accept TC_Credit_OK;
+ -- We need this to insure that we evaluate the guards at least
+ -- once when Credit_Overloaded is False. Otherwise, tasks
+ -- could stay queued on Wait_for_Underload forever (starvation).
+ or
+ terminate;
+ end select;
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Distributor");
+ end Distributor;
+
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ --
+ task body Credit_Computation is
+
+ Message_Count : integer := 0;
+
+ begin
+ loop
+ select
+ accept Input ( Transaction : acc_Transaction_Record) do
+ if Credit_Overloaded.Value and
+ Transaction.Priority = Low then
+ -- We should not be getting any Low Priority messages. They
+ -- should be waiting on the Distributor's Wait_for_Underload
+ -- queue
+ Report.Failed
+ ("Credit Task: Low priority transaction during overload");
+ end if;
+ -- Perform the computations required for this transaction
+ null; -- stub
+
+ -- For the test:
+ if Transaction.Time_Stamp = Base_Time then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- The following is all Test Control code:
+ Transaction.Return_Value := Credit_Return;
+ Message_Count := Message_Count + 1;
+ --
+ -- Now take special action depending on which Message
+ if Message_Count = 1 then
+ -- After the first message :
+ Credit_Overloaded.Set_True;
+ -- Now flag the Line_Driver that the second and subsequent
+ -- messages may now be sent
+ TC_First_Message_Has_Arrived.Set_True;
+ end if;
+ if Message_Count = 3 then
+ -- The two high priority transactions created subsequent
+ -- to the overload have now been processed
+ Credit_Overloaded.Set_False;
+ end if;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ --
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ null; -- stub
+
+ -- For the test:
+ if Transaction.Time_Stamp = Base_Time then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+
+ end Debit_Computation;
+
+
+begin -- c954012
+ Report.Test ("C954012", "Requeue within an accept body" &
+ " to another entry in the same task");
+
+ Line_Driver.Start; -- Start the test
+
+ -- Ensure that the message tasks complete before reporting the result
+ while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected)
+ or (not TC_Debit_Message_Complete.Value) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954012;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954013.a b/gcc/testsuite/ada/acats/tests/c9/c954013.a
new file mode 100644
index 000000000..a9de8c56b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954013.a
@@ -0,0 +1,521 @@
+-- C954013.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue is cancelled and that the requeuing task is
+-- unaffected when the calling task is aborted.
+-- Specifically, check requeue to an entry in a different task,
+-- requeue where the entry has parameters, and requeue with abort.
+--
+-- TEST DESCRIPTION:
+-- Abort a task that has a call requeued to the entry queue of another
+-- task. We do this by sending two messages to the Distributor which
+-- requeues them to the Credit task. In the accept body of the Credit
+-- task we wait for the second message to arrive then check that an
+-- abort of the second message task does result in the requeue being
+-- removed. The Line Driver task which generates the messages and the
+-- Credit task communicate artificially in this test to arrange for the
+-- proper timing of the messages and the abort. One extra message is
+-- sent to the Debit task to ensure that the Distributor is still viable
+-- and has been unaffected by the abort.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life, dynamic
+-- and unpredictable at the time of message generation. All rerouting in
+-- this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 25 Nov 95 SAIC Fixed shared global variable problems for
+-- ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954013 is
+
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+
+ protected type Shared_Boolean (Initial_Value : Boolean := False) is
+ procedure Set_True;
+ procedure Set_False;
+ function Value return Boolean;
+ private
+ Current_Value : Boolean := Initial_Value;
+ end Shared_Boolean;
+
+ protected body Shared_Boolean is
+ procedure Set_True is
+ begin
+ Current_Value := True;
+ end Set_True;
+
+ procedure Set_False is
+ begin
+ Current_Value := False;
+ end Set_False;
+
+ function Value return Boolean is
+ begin
+ return Current_Value;
+ end Value;
+ end Shared_Boolean;
+
+
+ TC_Debit_Message_Complete : Shared_Boolean (False);
+ TC_Credit_Message_Complete : Shared_Boolean (False);
+
+
+ type Transaction_Code is (Credit, Debit);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Dist : Boolean := false;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ task Distributor is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Distributor;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+ -- This protected object is here for Test Control purposes only
+ protected TC_Prt is
+ procedure Set_First_Has_Arrived;
+ procedure Set_Second_Has_Arrived;
+ procedure Set_Abort_Has_Completed;
+ function First_Has_Arrived return Boolean;
+ function Second_Has_Arrived return Boolean;
+ function Abort_Has_Completed return Boolean;
+ private
+ First_Flag, Second_Flag, Abort_Flag : Boolean := false;
+ end TC_Prt;
+
+ protected body TC_Prt is
+
+ Procedure Set_First_Has_Arrived is
+ begin
+ First_Flag := true;
+ end Set_First_Has_Arrived;
+
+ Procedure Set_Second_Has_Arrived is
+ begin
+ Second_Flag := true;
+ end Set_Second_Has_Arrived;
+
+ Procedure Set_Abort_Has_Completed is
+ begin
+ Abort_Flag := true;
+ end Set_Abort_Has_Completed;
+
+ Function First_Has_Arrived return boolean is
+ begin
+ return First_Flag;
+ end First_Has_Arrived;
+
+ Function Second_Has_Arrived return boolean is
+ begin
+ return Second_Flag;
+ end Second_has_Arrived;
+
+ Function Abort_Has_Completed return boolean is
+ begin
+ return Abort_Flag;
+ end Abort_Has_Completed;
+
+ end TC_PRT;
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- TC: The Line Driver task would normally be designed to loop
+ -- continuously creating the messages as input is received. Simulate
+ -- this but limit it to three dummy messages for this test and use
+ -- special artificial checks to pace the messages out under controlled
+ -- conditions for the test; allow it to terminate at the end
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ TC_First_message_sent: Boolean := false;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ accept Start; -- Wait for trigger from main
+
+ for i in 1..3 loop -- TC: arbitrarily limit to two credit messages
+ -- and one debit, then complete
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record :=
+ new Transaction_Record;
+ begin
+ if not TC_First_Message_Sent then
+ -- send out the first message to start up the Credit task
+ Build_Credit_Record ( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ TC_First_Message_Sent := true;
+ elsif not TC_Prt.Abort_Has_Completed then
+ -- We have not yet processed the second message
+ -- Wait to send the second message until we know the first
+ -- has arrived at the Credit task and that task is in the
+ -- accept body
+ while not TC_Prt.First_Has_Arrived loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- We can now send the second message
+ Build_Credit_Record( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+
+ -- Now wait for the second to arrive on the Credit input queue
+ while not TC_Prt.Second_Has_Arrived loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- At this point: The Credit task is in the accept block
+ -- dealing with the first message and the second message is
+ -- is on the input queue
+ abort Next_Message_Task.all; -- Note: we are still in the
+ -- declare block for the
+ -- second message task
+
+ -- Make absolutely certain that all the actions
+ -- associated with the abort have been completed, that the
+ -- task has gone from Abnormal right through to
+ -- Termination. All requeues that are to going to be
+ -- cancelled will have been by the point of Termination.
+ while not Next_Message_Task.all'terminated loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+
+ -- We now signal the Credit task that the abort has taken place
+ -- so that it can check that the entry queue is empty as the
+ -- requeue should have been cancelled
+ TC_Prt.Set_Abort_Has_Completed;
+ else
+ -- The main part of the test is complete. Send one Debit message
+ -- as further exercise of the Distributor to ensure it has not
+ -- been affected by the cancellation of the requeue.
+ Build_Debit_Record ( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end if;
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+
+ accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+ -- For the test check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= Credit_Return or
+ This_Transaction.TC_Message_Count /= 1 or not
+ This_Transaction.TC_Thru_Dist then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Credit_Message_Complete.Set_True;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or not
+ This_Transaction.TC_Thru_Dist then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Debit_Message_Complete.Set_True;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ task body Distributor is
+
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Show that this message did pass through the Distributor Task
+ Transaction.TC_Thru_Dist := true;
+
+ -- Pass this transaction on the the appropriate computation
+ -- task
+ case Transaction.Code is
+ when Credit =>
+ requeue Credit_Computation.Input with abort;
+ when Debit =>
+ requeue Debit_Computation.Input with abort;
+ end case;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Distributor");
+ end Distributor;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ task body Credit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input ( Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this transaction
+ --
+ null; -- stub
+
+ -- The rest of this code is for Test Control
+ --
+ if not Transaction.TC_Thru_Dist then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Credit_Return;
+ -- one, and only one message should pass through
+ if Message_Count /= 0 then
+ Report.Failed ("Aborted Requeue was not cancelled -1");
+ end if;
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+
+
+ -- Having done the basic housekeeping we now need to signal
+ -- that we are in the accept body of the credit task. The
+ -- first message has arrived and the Line Driver may now send
+ -- the second one
+ TC_Prt.Set_First_Has_Arrived;
+
+ -- Now wait for the second to arrive
+
+ while Input'Count = 0 loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ -- Second message has been requeued - the Line driver may
+ -- now abort the calling task
+ TC_Prt.Set_Second_Has_Arrived;
+
+ -- Now wait for the Line Driver to signal that the abort of
+ -- the first task is complete - the requeue should be cancelled
+ -- at this time
+ while not TC_Prt.Abort_Has_Completed loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ if Input'Count /=0 then
+ Report.Failed ("Aborted Requeue was not cancelled -2");
+ end if;
+ -- We can now complete the rendezvous with the first caller
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ --
+ null; -- stub
+
+ -- The rest of this code is for Test Control
+ --
+ if not Transaction.TC_Thru_Dist then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+
+ end Debit_Computation;
+
+
+begin -- c954013
+
+ Report.Test ("C954013", "Abort a task that has a call requeued");
+
+ Line_Driver.Start; -- start the test
+
+ -- Wait for the message tasks to complete before calling Report.Result.
+ -- Although two Credit tasks are generated one is aborted so only
+ -- one completes, thus a single flag is sufficient
+ -- Note: the test will hang here if there is a problem with the
+ -- completion of the tasks
+ while not (TC_Credit_Message_Complete.Value and
+ TC_Debit_Message_Complete.Value) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954013;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954014.a b/gcc/testsuite/ada/acats/tests/c9/c954014.a
new file mode 100644
index 000000000..53e45a090
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954014.a
@@ -0,0 +1,485 @@
+-- C954014.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue is not canceled and that the requeueing
+-- task is unaffected when a calling task is aborted. Check that the
+-- abort is deferred until the entry call is complete.
+-- Specifically, check requeue to an entry in a different task,
+-- requeue where the entry call has parameters, and requeue
+-- without the abort option.
+--
+-- TEST DESCRIPTION
+-- In the Driver create a task that places a call on the
+-- Distributor. In the Distributor requeue this call on the Credit task.
+-- Abort the calling task when it is known to be in rendezvous with the
+-- Credit task. (We arrange this by using artificial synchronization
+-- points in the Driver and the accept body of the Credit task) Ensure
+-- that the abort is deferred (the task is not terminated) until the
+-- accept body completes. Afterwards, send one extra message through
+-- the Distributor to check that the requeueing task has not been
+-- disrupted.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life, dynamic
+-- and unpredictable at the time of message generation. All rerouting in
+-- this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 25 Nov 95 SAIC Replaced global variables with protected objects
+-- for ACVC 2.0.1.
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954014 is
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+
+ protected type Shared_Boolean (Initial_Value : Boolean := False) is
+ procedure Set_True;
+ procedure Set_False;
+ function Value return Boolean;
+ private
+ Current_Value : Boolean := Initial_Value;
+ end Shared_Boolean;
+
+ protected body Shared_Boolean is
+ procedure Set_True is
+ begin
+ Current_Value := True;
+ end Set_True;
+
+ procedure Set_False is
+ begin
+ Current_Value := False;
+ end Set_False;
+
+ function Value return Boolean is
+ begin
+ return Current_Value;
+ end Value;
+ end Shared_Boolean;
+
+
+ TC_Debit_Message_Complete : Shared_Boolean (False);
+
+ -- Synchronization flags for handshaking between the Line_Driver
+ -- and the Accept body in the Credit Task
+ TC_Handshake_A : Shared_Boolean (False);
+ TC_Handshake_B : Shared_Boolean (False);
+ TC_Handshake_C : Shared_Boolean (False);
+ TC_Handshake_D : Shared_Boolean (False);
+ TC_Handshake_E : Shared_Boolean (False);
+ TC_Handshake_F : Shared_Boolean (False);
+
+
+ type Transaction_Code is (Credit, Debit);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Distrib : Boolean;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry start;
+ end Line_Driver;
+
+ task Distributor is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Distributor;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- TC: The Line Driver task would normally be designed to loop
+ -- continuously creating the messages as input is received. Simulate
+ -- this but limit it to two dummy messages for this test and use
+ -- special artificial handshaking checks with the Credit accept body
+ -- to control the test. Allow it to terminate at the end
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ TC_First_message_sent: Boolean := false;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ accept Start; -- Wait for trigger from main
+
+ for i in 1..2 loop -- TC: arbitrarily limit to one credit message
+ -- and one debit, then complete
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record :=
+ new Transaction_Record;
+ begin
+ if not TC_First_Message_Sent then
+ -- send out the first message which will be aborted
+ Build_Credit_Record ( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ TC_First_Message_Sent := true;
+
+ -- Wait for Credit task to get into the accept body
+ -- The call from the Message Task has been requeued by
+ -- the distributor
+ while not TC_Handshake_A.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- Abort the calling task; the Credit task is guaranteed to
+ -- be in the accept body
+ abort Next_Message_Task.all; -- We are still in this declare
+ -- block
+
+ -- Inform the Credit task that the abort has been initiated
+ TC_Handshake_B.Set_True;
+
+ -- Now wait for the "acknowledgment" from the Credit task
+ -- this ensures a complete task switch (at least)
+ while not TC_Handshake_C.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- The aborted task must not terminate till the accept body
+ -- has completed
+ if Next_Message_Task'terminated then
+ Report.Failed ("The abort was not deferred");
+ end if;
+
+ -- Inform the Credit task that the termination has been checked
+ TC_Handshake_D.Set_True;
+
+ -- Now wait for the completion of the accept body in the
+ -- Credit task
+ while not TC_Handshake_E.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ while not ( Next_Message_Task'terminated ) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- Indicate to the Main program that this section is complete
+ TC_Handshake_F.Set_True;
+
+ else
+ -- The main part of the test is complete. Send one Debit message
+ -- as further exercise of the Distributor to ensure it has not
+ -- been affected by the abort of the requeue;
+ Build_Debit_Record ( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end if;
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+
+ accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+ -- For the test check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ -- The only Credit message was the one that should have been aborted
+ Report.Failed ("Abort was not effective");
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or not
+ This_Transaction.TC_Thru_Distrib then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Debit_Message_Complete.Set_True;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ task body Distributor is
+
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+
+ -- Indicate that the message did pass through the
+ -- Distributor Task
+ Transaction.TC_Thru_Distrib := true;
+
+ -- Pass this transaction on the appropriate computation
+ -- task
+ case Transaction.Code is
+ when Credit =>
+ requeue Credit_Computation.Input; -- without abort
+ when Debit =>
+ requeue Debit_Computation.Input; -- without abort
+ end case;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Distributor");
+ end Distributor;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ task body Credit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input ( Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this transaction
+ --
+ null; -- stub
+
+ -- The rest of this code is for Test Control
+ --
+ if not Transaction.TC_Thru_Distrib then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Credit_Return;
+ -- one, and only one message should pass through
+ if Message_Count /= 0 then
+ Report.Failed ("Aborted Requeue was not canceled -1");
+ end if;
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+
+ -- Having done the basic housekeeping we now need to signal
+ -- that we are in the accept body of the credit task. The
+ -- message has arrived and the Line Driver may now abort the
+ -- calling task
+ TC_Handshake_A.Set_True;
+
+ -- Now wait for the Line Driver to inform us the calling
+ -- task has been aborted
+ while not TC_Handshake_B.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- The abort has taken place
+ -- Inform the Line Driver that we are still running in the
+ -- accept body
+ TC_Handshake_C.Set_True;
+
+ -- Now wait for the Line Driver to digest this information
+ while not TC_Handshake_D.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- The Line driver has checked that the caller is not terminated
+ -- We can now complete the accept
+
+ end Input;
+ -- We are out of the accept
+ TC_Handshake_E.Set_True;
+
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ --
+ null; -- stub
+
+ -- The rest of this code is for Test Control
+ --
+ if not Transaction.TC_Thru_Distrib then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+
+ end Debit_Computation;
+
+
+begin -- c954014
+ Report.Test ("C954014", "Abort a task that has a call" &
+ " requeued_without_abort");
+
+ Line_Driver.Start; -- Start the test
+
+ -- Wait for the message tasks to complete before reporting the result
+ --
+ while not (TC_Handshake_F.Value -- abort not effective?
+ and TC_Debit_Message_Complete.Value -- Distributor affected?
+ and TC_Handshake_E.Value ) loop -- accept not completed?
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954014;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954015.a b/gcc/testsuite/ada/acats/tests/c9/c954015.a
new file mode 100644
index 000000000..c86e1078e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954015.a
@@ -0,0 +1,549 @@
+-- C954015.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that requeued calls to task entries may, in turn, be requeued.
+-- Check that the intermediate requeues are not blocked and that the
+-- original caller remains blocked until the last requeue is complete.
+-- This test uses:
+-- Call with parameters
+-- Requeue with abort
+--
+-- TEST DESCRIPTION
+-- A call is placed on the input queue of the Distributor. The
+-- Distributor requeues to the Credit task; the Credit task requeues to a
+-- secondary task which, in turn requeues to yet another task. This
+-- continues down the chain. At the furthest point of the chain the
+-- rendezvous is completed. To verify the action, the furthest task
+-- waits in the accept statement for a second message to arrive before
+-- completing. This second message can only arrive if none of the earlier
+-- tasks in the chain are blocked waiting for completion. Apart from
+-- the two Credit messages which are used to check the requeue chain one
+-- Debit message is sent to validate the mix.
+--
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life, dynamic
+-- and unpredictable at the time of message generation. All rerouting in
+-- this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+with ImpDef;
+
+procedure C954015 is
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+ -- Mechanism to count the number of Credit Message tasks completed
+ protected TC_Tasks_Completed is
+ procedure Increment;
+ function Count return integer;
+ private
+ Number_Complete : integer := 0;
+ end TC_Tasks_Completed;
+
+ TC_Expected_To_Complete : constant integer := 3;
+
+
+ -- Values added to the Return_Value indicating passage through the
+ -- particular task
+ TC_Credit_Value : constant integer := 1;
+ TC_Sub_1_Value : constant integer := 2;
+ TC_Sub_2_Value : constant integer := 3;
+ TC_Sub_3_Value : constant integer := 4;
+ TC_Sub_4_Value : constant integer := 5;
+ --
+ TC_Full_Value : integer := TC_Credit_Value + TC_Sub_1_Value +
+ TC_Sub_2_Value + TC_Sub_3_Value +
+ TC_Sub_4_Value;
+
+ type Transaction_Code is (Credit, Debit);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Distrib : Boolean := false;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ task Distributor is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Distributor;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+ -- The following are almost identical for the purpose of the test
+ task Credit_Sub_1 is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Sub_1;
+ --
+ task Credit_Sub_2 is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Sub_2;
+ --
+ task Credit_Sub_3 is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Sub_3;
+
+ -- This is the last in the chain
+ task Credit_Sub_4 is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Sub_4;
+
+
+ -- Mechanism to count the number of Message tasks completed (Credit)
+ protected body TC_Tasks_Completed is
+ procedure Increment is
+ begin
+ Number_Complete := Number_Complete + 1;
+ end Increment;
+
+ function Count return integer is
+ begin
+ return Number_Complete;
+ end Count;
+ end TC_Tasks_Completed;
+
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- The Line Driver task would normally be designed to loop continuously
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to the number of dummy messages needed for this
+ -- test and allow it to terminate at that point.
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ TC_Last_was_for_credit : Boolean := false;
+
+ -- Arbitrary limit for the number of messages sent for this test
+ type TC_Trans_Range is range 1..3;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+
+ begin
+
+ accept Start; -- wait for trigger from Main
+
+ -- Arbitrarily limit the loop to the number needed for this test only
+ for Transaction_Numb in TC_Trans_Range loop
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record :=
+ new Transaction_Record;
+ begin
+ -- Artificially send out in the order required
+ case Transaction_Numb is
+ when 1 =>
+ Build_Credit_Record( Next_Transaction );
+ when 2 =>
+ Build_Credit_Record( Next_Transaction );
+ when 3 =>
+ Build_Debit_Record ( Next_Transaction );
+ end case;
+
+ -- Present the record to the message task
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+
+ accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+
+ -- The following is all Test Control Code
+
+ -- Check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= TC_Full_Value or not
+ This_Transaction.TC_Thru_Distrib then
+ Report.Failed ("Expected path not traversed - CR");
+ end if;
+ if
+ This_Transaction.TC_Message_Count not in 1..2 then
+ Report.Failed ("Incorrect Message Count");
+ end if;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or not
+ This_Transaction.TC_Thru_Distrib then
+ Report.Failed ("Expected path not traversed - DB");
+ end if;
+ end if;
+ TC_Tasks_Completed.Increment;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ task body Distributor is
+
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Show that the message did pass through the Distributor Task
+ Transaction.TC_Thru_Distrib := true;
+
+ -- Pass this transaction on to the appropriate computation
+ -- task
+ case Transaction.Code is
+ when Credit =>
+ requeue Credit_Computation.Input with abort;
+ when Debit =>
+ requeue Debit_Computation.Input with abort;
+ end case;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Distributor");
+ end Distributor;
+
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task the message is
+ -- passed on for further processing to some subsidiary task. The choice
+ -- of subsidiary task is made according to criteria not specified in
+ -- this test.
+ --
+ task body Credit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input ( Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this transaction
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_Thru_Distrib then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test, plug a known value and count
+ Transaction.Return_Value := TC_Credit_Value;
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+
+ -- Depending on transaction content send it on to the
+ -- some other task for further processing
+ -- TC: Arbitrarily send the message on to Credit_Sub_1
+ requeue Credit_Sub_1.Input with abort;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ task body Credit_Sub_1 is
+ begin
+ loop
+ select
+ accept Input(Transaction : acc_Transaction_Record) do
+ -- Process this transaction
+ null; -- stub
+
+ -- Add the value showing passage through this task
+ Transaction.Return_Value :=
+ Transaction.Return_Value + TC_Sub_1_Value;
+ -- Depending on transaction content send it on to the
+ -- some other task for further processing
+ -- Arbitrarily send the message on to Credit_Sub_2
+ requeue Credit_Sub_2.Input with abort;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Sub_1");
+
+ end Credit_Sub_1;
+
+ task body Credit_Sub_2 is
+ begin
+ loop
+ select
+ accept Input(Transaction : acc_Transaction_Record) do
+ -- Process this transaction
+ null; -- stub
+
+ -- Add the value showing passage through this task
+ Transaction.Return_Value :=
+ Transaction.Return_Value + TC_Sub_2_Value;
+ -- Depending on transaction content send it on to the
+ -- some other task for further processing
+ -- Arbitrarily send the message on to Credit_Sub_3
+ requeue Credit_Sub_3.Input with abort;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Sub_2");
+ end Credit_Sub_2;
+
+ task body Credit_Sub_3 is
+ begin
+ loop
+ select
+ accept Input(Transaction : acc_Transaction_Record) do
+ -- Process this transaction
+ null; -- stub
+
+ -- Add the value showing passage through this task
+ Transaction.Return_Value :=
+ Transaction.Return_Value + TC_Sub_3_Value;
+ -- Depending on transaction content send it on to the
+ -- some other task for further processing
+ -- Arbitrarily send the message on to Credit_Sub_4
+ requeue Credit_Sub_4.Input with abort;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Sub_3");
+ end Credit_Sub_3;
+
+ -- This is the last in the chain of tasks to which transactions will
+ -- be requeued
+ --
+ task body Credit_Sub_4 is
+
+ TC_First_Message : Boolean := true;
+
+ begin
+ loop
+ select
+ accept Input(Transaction : acc_Transaction_Record) do
+ -- Process this transaction
+ null; -- stub
+
+ -- Add the value showing passage through this task
+ Transaction.Return_Value :=
+ Transaction.Return_Value + TC_Sub_4_Value;
+ -- TC: stay in the accept body dealing with the first message
+ -- until the second arrives. If any of the requeues are
+ -- blocked the test will hang here indicating failure
+ if TC_First_Message then
+ while Input'count = 0 loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ TC_First_Message := false;
+ end if;
+ -- for the second message, just complete the rendezvous
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Sub_4");
+ end Credit_Sub_4;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ --
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_Thru_Distrib then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+
+ end Debit_Computation;
+
+
+begin
+
+ Report.Test ("C954015", "Test multiple levels of requeue to task entry");
+
+ Line_Driver.Start; -- Start the test
+
+ -- Ensure that the message tasks completed before calling Result
+ while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954015;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954016.a b/gcc/testsuite/ada/acats/tests/c9/c954016.a
new file mode 100644
index 000000000..1390801ee
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954016.a
@@ -0,0 +1,182 @@
+-- C954016.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that when a task that is called by a requeue is aborted, the
+-- original caller receives Tasking_Error and the requeuing task is
+-- unaffected.
+--
+-- TEST DESCRIPTION:
+-- The Intermediate task requeues a call from the Original_Caller to the
+-- Receiver. While the Receiver is in the accept body for this
+-- rendezvous the Main aborts it. Check that Tasking_Error is raised in
+-- the Original_Caller, that the Receiver does, indeed, get aborted and
+-- the Intermediate task is undisturbed.
+-- There are several delay loops in this test any one of which could
+-- cause it to hang which would constitute failure.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 25 Nov 95 SAIC Replaced shared global variable with protected
+-- object for ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954016 is
+
+ TC_Original_Caller_Complete : Boolean := false;
+ TC_Intermediate_Complete : Boolean := false;
+
+
+ protected type Shared_Boolean (Initial_Value : Boolean := False) is
+ procedure Set_True;
+ procedure Set_False;
+ function Value return Boolean;
+ private
+ Current_Value : Boolean := Initial_Value;
+ end Shared_Boolean;
+
+ protected body Shared_Boolean is
+ procedure Set_True is
+ begin
+ Current_Value := True;
+ end Set_True;
+
+ procedure Set_False is
+ begin
+ Current_Value := False;
+ end Set_False;
+
+ function Value return Boolean is
+ begin
+ return Current_Value;
+ end Value;
+ end Shared_Boolean;
+
+ TC_Receiver_in_Accept : Shared_Boolean (False);
+
+
+ task Original_Caller is
+ entry Start;
+ end Original_Caller;
+
+ task Intermediate is
+ entry Input;
+ entry TC_Abort_Process_Complete;
+ end Intermediate;
+
+ task Receiver is
+ entry Input;
+ entry TC_Never_Called;
+ end Receiver;
+
+
+ task body Original_Caller is
+ begin
+ accept Start; -- wait for the trigger from Main
+
+ Intermediate.Input;
+ Report.Failed ("Tasking_Error not raised in Original_Caller task");
+
+ exception
+ when tasking_error =>
+ TC_Original_Caller_Complete := true; -- expected behavior
+ when others =>
+ Report.Failed ("Unexpected Exception in Original_Caller task");
+ end Original_Caller;
+
+
+ task body Intermediate is
+ begin
+ accept Input do
+ -- Within this accept call another task
+ requeue Receiver.Input with abort;
+ end Input;
+
+ -- Wait for Main to ensure that the abort housekeeping is finished
+ accept TC_Abort_Process_Complete;
+
+ TC_Intermediate_Complete := true;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Intermediate task");
+ end Intermediate;
+
+
+ task body Receiver is
+ begin
+ accept Input do
+ TC_Receiver_in_Accept.Set_True;
+ -- Hang within the accept body to allow Main to abort this task
+ accept TC_Never_Called;
+ end Input;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Receiver Task");
+
+ end Receiver;
+
+
+begin
+ Report.Test ("C954016", "Requeue: abort the called task");
+
+ Original_Caller.Start;
+
+ -- Wait till the rendezvous with Receiver is started
+ while not TC_Receiver_in_Accept.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- At this point the Receiver is guaranteed to be in its accept
+ --
+ abort Receiver;
+
+ -- Wait for the whole of the abort process to complete
+ while not ( Original_Caller'terminated and Receiver'terminated ) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- Inform the Intermediate task that the process is complete to allow
+ -- it to continue to completion itself
+ Intermediate.TC_Abort_Process_Complete;
+
+ -- Wait for everything to settle before reporting the result
+ while not ( Intermediate'terminated ) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+
+ if not ( TC_Original_Caller_Complete and TC_Intermediate_Complete ) then
+ Report.Failed ("Proper paths not traversed");
+ end if;
+
+ Report.Result;
+
+end C954016;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954017.a b/gcc/testsuite/ada/acats/tests/c9/c954017.a
new file mode 100644
index 000000000..a5447a756
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954017.a
@@ -0,0 +1,184 @@
+-- C954017.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that when an exception is raised in the rendezvous of a task
+-- that was called by a requeue the exception is propagated to the
+-- original caller and that the requeuing task is unaffected.
+--
+-- TEST DESCRIPTION:
+-- The Intermediate task requeues a call from the Original_Caller to the
+-- Receiver. While the Receiver is in the accept body for this
+-- rendezvous a Constraint_Error exception is raised. Check that the
+-- exception is propagated to the Original_Caller, that the Receiver's
+-- normal exception logic is employed and that the Intermediate task
+-- is undisturbed.
+-- There are several delay loops in this test any one of which could
+-- cause it to hang (and thus fail).
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 25 Nov 95 SAIC Fixed shared global variable problem for
+-- ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+
+
+procedure C954017 is
+
+ TC_Original_Caller_Complete : Boolean := false;
+ TC_Intermediate_Complete : Boolean := false;
+ TC_Receiver_Complete : Boolean := false;
+ TC_Exception : Exception;
+
+
+ protected type Shared_Boolean (Initial_Value : Boolean := False) is
+ procedure Set_True;
+ procedure Set_False;
+ function Value return Boolean;
+ private
+ Current_Value : Boolean := Initial_Value;
+ end Shared_Boolean;
+
+ protected body Shared_Boolean is
+ procedure Set_True is
+ begin
+ Current_Value := True;
+ end Set_True;
+
+ procedure Set_False is
+ begin
+ Current_Value := False;
+ end Set_False;
+
+ function Value return Boolean is
+ begin
+ return Current_Value;
+ end Value;
+ end Shared_Boolean;
+
+ TC_Exception_Process_Complete : Shared_Boolean (False);
+
+ task Original_Caller is
+ entry Start;
+ end Original_Caller;
+
+ task Intermediate is
+ entry Input;
+ end Intermediate;
+
+ task Receiver is
+ entry Input;
+ end Receiver;
+
+
+ task body Original_Caller is
+ begin
+ accept Start; -- wait for the trigger from Main
+
+ Intermediate.Input;
+ Report.Failed ("Exception not propagated to Original_Caller");
+
+ exception
+ when TC_Exception =>
+ TC_Original_Caller_Complete := true; -- Expected behavior
+ when others =>
+ Report.Failed ("Unexpected Exception in Original_Caller task");
+ end Original_Caller;
+
+
+ task body Intermediate is
+ begin
+ accept Input do
+ -- Within this accept call another task
+ requeue Receiver.Input with abort;
+ end Input;
+
+ -- Wait for Main to ensure that the exception housekeeping is finished
+ while not TC_Exception_Process_Complete.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ TC_Intermediate_Complete := true;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Intermediate task");
+ end Intermediate;
+
+
+ task body Receiver is
+ --
+ begin
+ accept Input do
+ null; -- the user code for the rendezvous is stubbed out
+
+ -- Test Control: Raise an exception in the destination task which
+ -- should then be propagated
+ raise TC_Exception;
+
+ end Input;
+ exception
+ when TC_Exception =>
+ TC_Receiver_Complete := true; -- expected behavior
+ when others =>
+ Report.Failed ("Unexpected Exception in Receiver Task");
+ end Receiver;
+
+
+begin
+
+ Report.Test ("C954017", "Requeue: exception processing");
+
+ Original_Caller.Start; -- Start the test after the Report.Test
+
+ -- Wait for the whole of the exception process to complete
+ while not ( Original_Caller'terminated and Receiver'terminated ) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- Inform the Intermediate task that the process is complete to allow
+ -- it to continue to completion itself
+ TC_Exception_Process_Complete.Set_True;
+
+ -- Wait for everything to settle before reporting the result
+ while not ( Intermediate'terminated ) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+
+ if not ( TC_Original_Caller_Complete and
+ TC_Intermediate_Complete and
+ TC_Receiver_Complete) then
+ Report.Failed ("Proper paths not traversed");
+ end if;
+
+ Report.Result;
+
+end C954017;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954018.a b/gcc/testsuite/ada/acats/tests/c9/c954018.a
new file mode 100644
index 000000000..a9da1e06b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954018.a
@@ -0,0 +1,227 @@
+-- C954018.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if a task is aborted while a requeued call is queued
+-- on one of its entries the original caller receives Tasking_Error
+-- and the requeuing task is unaffected.
+-- This test uses: Requeue to an entry in a different task
+-- Parameterless call
+-- Requeue with abort
+--
+-- TEST DESCRIPTION:
+-- The Intermediate task requeues a call from the Original_Caller to the
+-- Receiver on an entry with a guard that is always false. While the
+-- Original_Caller is still queued the Receiver is aborted.
+-- Check that Tasking_Error is raised in the Original_Caller, that the
+-- Receiver does, indeed, get aborted and the Intermediate task
+-- is undisturbed.
+-- There are several delay loops in this test any one of which could
+-- cause it to hang and thus indicate failure.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+with ImpDef;
+
+
+procedure C954018 is
+
+
+ -- Protected object to control the shared test variables
+ --
+ protected TC_State is
+ function On_Entry_Queue return Boolean;
+ procedure Set_On_Entry_Queue;
+ function Original_Caller_Complete return Boolean;
+ procedure Set_Original_Caller_Complete;
+ function Intermediate_Complete return Boolean;
+ procedure Set_Intermediate_Complete;
+ private
+ On_Entry_Queue_Flag : Boolean := false;
+ Original_Caller_Complete_Flag : Boolean := false;
+ Intermediate_Complete_Flag : Boolean := false;
+ end TC_State;
+ --
+ --
+ protected body TC_State is
+ function On_Entry_Queue return Boolean is
+ begin
+ return On_Entry_Queue_Flag;
+ end On_Entry_Queue;
+
+ procedure Set_On_Entry_Queue is
+ begin
+ On_Entry_Queue_Flag := true;
+ end Set_On_Entry_Queue;
+
+ function Original_Caller_Complete return Boolean is
+ begin
+ return Original_Caller_Complete_Flag;
+ end Original_Caller_Complete;
+
+ procedure Set_Original_Caller_Complete is
+ begin
+ Original_Caller_Complete_Flag := true;
+ end Set_Original_Caller_Complete;
+
+ function Intermediate_Complete return Boolean is
+ begin
+ return Intermediate_Complete_Flag;
+ end Intermediate_Complete;
+
+ procedure Set_Intermediate_Complete is
+ begin
+ Intermediate_Complete_Flag := true;
+ end Set_Intermediate_Complete;
+
+ end TC_State;
+
+ --================================
+
+ task Original_Caller is
+ entry Start;
+ end Original_Caller;
+
+ task Intermediate is
+ entry Input;
+ entry TC_Abort_Process_Complete;
+ end Intermediate;
+
+ task Receiver is
+ entry Input;
+ end Receiver;
+
+
+ task body Original_Caller is
+ begin
+ accept Start; -- wait for the trigger from Main
+
+ Intermediate.Input;
+ Report.Failed ("Tasking_Error not raised in Original_Caller task");
+
+ exception
+ when tasking_error =>
+ TC_State.Set_Original_Caller_Complete; -- expected behavior
+ when others =>
+ Report.Failed ("Unexpected Exception in Original_Caller task");
+ end Original_Caller;
+
+
+ task body Intermediate is
+ begin
+ accept Input do
+ -- Within this accept call another task
+ TC_State.Set_On_Entry_Queue;
+ requeue Receiver.Input with abort;
+ Report.Failed ("Requeue did not complete the Accept");
+ end Input;
+
+ -- Wait for Main to ensure that the abort housekeeping is finished
+ accept TC_Abort_Process_Complete;
+
+ TC_State.Set_Intermediate_Complete;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Intermediate task");
+ end Intermediate;
+
+
+ task body Receiver is
+ begin
+ loop
+ select
+ -- A call to Input will be placed on the queue and never serviced
+ when Report.Equal (1,2) => -- Always false
+ accept Input do
+ Report.Failed ("Receiver in Accept");
+ end Input;
+ or
+ delay ImpDef.Minimum_Task_Switch;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Receiver Task");
+
+ end Receiver;
+
+
+begin
+
+ Report.Test ("C954018", "Requeue: abort the called task" &
+ " while Caller is still queued");
+
+ Original_Caller.Start;
+
+
+ -- This is the main part of the test
+
+ -- Wait for the requeue
+ while not TC_State.On_Entry_Queue loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- Delay long enough to ensure that the requeue has "arrived" on
+ -- the entry queue. Note: TC_State.Set_On_Entry_Queue is called the
+ -- statement before the requeue
+ --
+ delay ImpDef.Switch_To_New_Task;
+
+ -- At this point the Receiver is guaranteed to have the requeue on
+ -- the entry queue
+ --
+ abort Receiver;
+
+ -- Wait for the whole of the abort process to complete
+ while not ( Original_Caller'terminated and Receiver'terminated ) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+
+ -- Inform the Intermediate task that the process is complete to allow
+ -- it to continue to completion itself
+ Intermediate.TC_Abort_Process_Complete;
+
+ -- Wait for everything to settle before reporting the result
+ while not ( Intermediate'terminated ) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+
+ if not ( TC_State.Original_Caller_Complete and
+ TC_State.Intermediate_Complete ) then
+ Report.Failed ("Proper paths not traversed");
+ end if;
+
+ Report.Result;
+
+end C954018;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954019.a b/gcc/testsuite/ada/acats/tests/c9/c954019.a
new file mode 100644
index 000000000..fafc6aa59
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954019.a
@@ -0,0 +1,314 @@
+-- C954019.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that when a requeue is to the same entry the items go to the
+-- right queue and that they are placed back on the end of the queue.
+--
+-- TEST DESCRIPTION:
+-- Simulate part of a message handling application where the messages are
+-- composed of several segments. The sequence of the segments within the
+-- message is specified by Seg_Sequence_No. The segments are handled by
+-- different tasks and finally forwarded to an output driver. The
+-- segments can arrive in any order but must be assembled into the proper
+-- sequence for final output. There is a Sequencer task interposed
+-- before the Driver. This takes the segments of the message off the
+-- Ordering_Queue and those that are in the right order it sends on to
+-- the driver; those that are out of order it places back on the end of
+-- the queue.
+--
+-- The test just simulates the arrival of the segments at the Sequencer.
+-- The task generating the segments handshakes with the Sequencer during
+-- the "Await Arrival" phase ensuring that the three segments of a
+-- message arrive in REVERSE order (the End-of-Message segment arrives
+-- first and the Header last). In the first cycle the sequencer pulls
+-- segments off the queue and puts them back on the end till it
+-- encounters the header. It checks the sequence of the ones it pulls
+-- off in case the segments are being put back on in the wrong part of
+-- the queue. Having cycled once through it no longer verifies the
+-- sequence - it just executes the "application" code for the correct
+-- order for dispatch to the driver.
+--
+-- In this simple example no attempt is made to address segments of
+-- another message arriving or any other error conditions (such as
+-- missing segments, timing etc.)
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 19 Dec 94 SAIC Remove parameter from requeue statement
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954019 is
+begin
+
+
+ Report.Test ("C954019", "Check Requeue to the same Accept");
+
+ declare -- encapsulate the test
+
+ type Segment_Sequence is range 1..8;
+ Header : constant Segment_Sequence := Segment_Sequence'first;
+
+ type Message_Segment is record
+ ID : integer; -- Message ID
+ Seg_Sequence_No : Segment_Sequence; -- Within the message
+ Alpha : string (1..128);
+ EOM : Boolean := false; -- true for final msg segment
+ end record;
+ type acc_Message_Segment is access Message_Segment;
+
+ task TC_Simulate_Arrival;
+
+ task type Carrier_Task is
+ entry Input ( Segment : acc_Message_Segment );
+ end Carrier_Task;
+ type acc_Carrier_Task is access Carrier_Task;
+
+ task Sequencer is
+ entry Ordering_Queue ( Segment : acc_Message_Segment );
+ entry TC_Handshake_1;
+ entry TC_Handshake_2;
+ end Sequencer;
+
+ task Output_Driver is
+ entry Input ( Segment : acc_Message_Segment );
+ end Output_Driver;
+
+
+ -- Simulate the arrival of three message segments in REVERSE order
+ --
+ task body TC_Simulate_Arrival is
+ begin
+
+ for i in 1..3 loop
+ declare
+ -- Create a task for the next message segment
+ Next_Segment_Task : acc_Carrier_Task := new Carrier_Task;
+ -- Create a record for the next segment
+ Next_Segment : acc_Message_Segment := new Message_Segment;
+ begin
+ if i = 1 then
+ -- Build the EOM segment as the first to "send"
+ Next_Segment.Seg_Sequence_No := Header + 2;
+ Next_Segment.EOM := true;
+ elsif i = 2 then
+ -- Wait for the first segment to arrive at the Sequencer
+ -- before "sending" the second
+ Sequencer.TC_Handshake_1;
+ -- Build the segment
+ Next_Segment.Seg_Sequence_No := Header + 1;
+ else
+ -- Wait for the second segment to arrive at the Sequencer
+ -- before "sending" the third
+ Sequencer.TC_Handshake_2;
+ -- Build the segment. The last segment in order to
+ -- arrive will be the "header" segment
+ Next_Segment.Seg_Sequence_No := Header;
+ end if;
+ -- pass the record to its carrier
+ Next_Segment_Task.Input ( Next_Segment );
+ end;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in TC_Simulate_Arrival");
+ end TC_Simulate_Arrival;
+
+
+ -- One of these is generated for each message segment and the flow
+ -- of the segments through the system is controlled by the calls the
+ -- task makes and the requeues of those calls
+ --
+ task body Carrier_Task is
+ This_Segment : acc_Message_Segment := new Message_Segment;
+ begin
+ accept Input ( Segment : acc_Message_Segment ) do
+ This_Segment.all := Segment.all;
+ end Input;
+ null; --:: stub. Pass the segment around the application as needed
+
+ -- Now output the segment to the Output_Driver. First we have to
+ -- go through the Sequencer.
+ Sequencer.Ordering_Queue ( This_Segment );
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Carrier_Task");
+ end Carrier_Task;
+
+
+ -- Pull segments off the Ordering_Queue and deliver them in the correct
+ -- sequence to the Output_Driver.
+ --
+ task body Sequencer is
+ Next_Needed : Segment_Sequence := Header;
+
+ TC_Await_Arrival : Boolean := true;
+ TC_First_Cycle : Boolean := true;
+ TC_Expected_Sequence : Segment_Sequence := Header+2;
+ begin
+ loop
+ select
+ accept Ordering_Queue ( Segment : acc_Message_Segment ) do
+
+ --=====================================================
+ -- This part is all Test_Control code
+
+ if TC_Await_Arrival then
+ -- We have to arrange that the segments arrive on the
+ -- queue in the right order, so we handshake with the
+ -- TC_Simulate_Arrival task to "send" only one at
+ -- a time
+ accept TC_Handshake_1; -- the first has arrived
+ -- and has been pulled off the
+ -- queue
+
+ -- Wait for the second to arrive (the first has already
+ -- been pulled off the queue
+ while Ordering_Queue'count < 1 loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ --
+ accept TC_Handshake_2; -- the second has arrived
+
+ -- Wait for the third to arrive
+ while Ordering_Queue'count < 2 loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- Subsequent passes through the loop, bypass this code
+ TC_Await_Arrival := false;
+
+
+ end if; -- await arrival
+
+ if TC_First_Cycle then
+ -- Check the order of the original three
+ if Segment.Seg_Sequence_No /= TC_Expected_Sequence then
+ -- The segments are not being pulled off in the
+ -- expected sequence. This could occur if the
+ -- requeue is not putting them back on the end.
+ Report.Failed ("Sequencer: Segment out of sequence");
+ end if; -- sequence check
+ -- Decrement the expected sequence
+ if TC_Expected_Sequence /= Header then
+ TC_Expected_Sequence := TC_Expected_Sequence - 1;
+ else
+ TC_First_Cycle := false; -- This is the Header - the
+ -- first two segments are
+ -- back on the queue
+
+ end if; -- decrementing
+ end if; -- first pass
+ --=====================================================
+
+ -- And this is the Application code
+ if Segment.Seg_Sequence_No = Next_Needed then
+ if Segment.EOM then
+ Next_Needed := Header; -- reset for next message
+ else
+ Next_Needed := Next_Needed + 1;
+ end if;
+ requeue Output_Driver.Input with abort;
+ Report.Failed ("Requeue did not complete accept body");
+ else
+ -- Not the next needed - put it back on the queue
+ requeue Sequencer.Ordering_Queue;
+ Report.Failed ("Requeue did not complete accept body");
+ end if;
+ end Ordering_Queue;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Sequencer");
+ end Sequencer;
+
+
+ task body Output_Driver is
+ This_Segment : acc_Message_Segment := new Message_Segment;
+
+ TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first;
+ TC_Segment_Total : integer := 0;
+ TC_Expected_Total : integer := 3;
+ begin
+ loop
+ -- Note: normally we would expect this Accept to be in a select
+ -- with terminate. For the test we exit the loop on completion
+ -- to give better control
+ accept Input ( Segment : acc_Message_Segment ) do
+ This_Segment.all := Segment.all;
+ end Input;
+
+ null; --::: stub - output the next segment of the message
+
+ -- The following is all test control code
+ --
+ if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then
+ Report.Failed ("Output_Driver: Segment out of sequence");
+ end if;
+ TC_Expected_Sequence := TC_Expected_Sequence + 1;
+
+ -- Now count the number of segments
+ TC_Segment_Total := TC_Segment_Total + 1;
+
+ -- Check the number and exit loop when complete
+ -- There must be exactly TC_Expected_Total in number and
+ -- the last one must be EOM
+ -- (test will hang if < TC_Expected_Total arrive
+ -- without EOM)
+ if This_Segment.EOM then
+ -- This is the last segment.
+ if TC_Segment_Total /= TC_Expected_Total then
+ Report.Failed ("EOM and wrong number of segments");
+ end if;
+ exit; -- the loop and terminate the task
+ elsif TC_Segment_Total = TC_Expected_Total then
+ Report.Failed ("No EOM found");
+ exit;
+ end if;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Output_Driver");
+ end Output_Driver;
+
+
+
+ begin
+
+ null;
+
+ end; -- encapsulation
+
+ Report.Result;
+
+end C954019;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954020.a b/gcc/testsuite/ada/acats/tests/c9/c954020.a
new file mode 100644
index 000000000..bc08a6bd4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954020.a
@@ -0,0 +1,422 @@
+-- C954020.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a call to a protected entry can be requeued to a task
+-- entry. Check that the requeue is placed on the correct entry; that the
+-- original caller waits for the completion of the requeue and continues
+-- after the requeued rendezvous. Check that the requeue does not block.
+-- Specifically, check a requeue with abort from a protected entry to
+-- an entry in a task.
+--
+-- TEST DESCRIPTION:
+--
+-- In the Distributor protected object, requeue two successive calls on
+-- the entries of two separate target tasks. Each task in each of the
+-- paths adds identifying information in the transaction being passed.
+-- This information is checked by the Message tasks on completion
+-- ensuring that the requeues have been placed on the correct queues.
+-- There is an artificial guard on the Credit Task to ensure that the
+-- input is queued; this guard is released by the Debit task which
+-- handles its input immediately. This ensures that we have one of the
+-- requeued items actually queued for later handling and also verifies
+-- that the requeuing process (in the protected object) is not blocked.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor object which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life,
+-- dynamic and unpredictable at the time of message generation. All
+-- rerouting in this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 06 Nov 95 SAIC Fixed problems for ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954020 is
+ Verbose : constant Boolean := False;
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+ protected type Message_Status is
+ procedure Set_Complete;
+ function Complete return Boolean;
+ private
+ Is_Complete : Boolean := False;
+ end Message_Status;
+
+ protected body Message_Status is
+ procedure Set_Complete is
+ begin
+ Is_Complete := True;
+ end Set_Complete;
+
+ function Complete return Boolean is
+ begin
+ return Is_Complete;
+ end Complete;
+ end Message_Status;
+
+ TC_Debit_Message : Message_Status;
+ TC_Credit_Message : Message_Status;
+
+ type Transaction_Code is (Credit, Debit);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Dist : Boolean := false;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+ protected Time_Lock is
+ procedure Credit_Start;
+ function Credit_Enabled return Boolean;
+ private
+ Credit_OK : Boolean := false;
+ end Time_Lock;
+
+ protected body Time_Lock is
+ procedure Credit_Start is
+ begin
+ Credit_OK := true;
+ end Credit_Start;
+
+ function Credit_Enabled return Boolean is
+ begin
+ return Credit_OK;
+ end Credit_Enabled;
+ end Time_Lock;
+
+
+
+ protected Distributor is
+ entry Input (Transaction : acc_Transaction_Record);
+ end Distributor;
+ --
+ --
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ protected body Distributor is
+ entry Input (Transaction : acc_Transaction_Record) when true is
+ -- barrier is always open
+ begin
+ -- Test Control: Set the indicator in the message to show it has
+ -- passed through the Distributor object
+ Transaction.TC_thru_Dist := true;
+
+ -- Pass this transaction on to the appropriate computation
+ -- task
+ case Transaction.Code is
+ when Credit =>
+ requeue Credit_Computation.Input with abort;
+ when Debit =>
+ requeue Debit_Computation.Input with abort;
+ end case;
+ end Input;
+ end Distributor;
+
+
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- The Line Driver task would normally be designed to loop continuously
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to two dummy messages for this test and allow it
+ -- to terminate at that point
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ TC_Last_was_for_credit : Boolean := false;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ accept Start; -- Wait for trigger from Main
+
+ for i in 1..2 loop -- arbitrarily limit to two messages for the test
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record
+ := new Transaction_Record;
+ begin
+ if TC_Last_was_for_credit then
+ Build_Debit_Record ( Next_Transaction );
+ else
+ Build_Credit_Record( Next_Transaction );
+ TC_Last_was_for_credit := true;
+ end if;
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+ accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ if Verbose then
+ Report.Comment ("message task got " &
+ Transaction_Code'Image (This_Transaction.Code));
+ end if;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+
+ -- The following is all Test Control Code
+
+ -- Check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= Credit_Return or
+ This_Transaction.TC_Message_Count /= 1 or
+ not This_Transaction.TC_thru_Dist then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Credit_Message.Set_Complete;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or
+ not This_Transaction.TC_thru_Dist then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ TC_Debit_Message.Set_Complete;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ --
+ task body Credit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ when Time_Lock.Credit_enabled =>
+ accept Input ( Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this transaction
+ null; -- stub
+
+ if Verbose then
+ Report.Comment ("Credit_Computation in accept");
+ end if;
+
+ -- For the test:
+ if not Transaction.TC_thru_Dist then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Credit_Return;
+ -- one, and only one message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+
+ end Input;
+ exit; -- only handle 1 transaction
+ else
+ -- poll until we can accept credit transaction
+ delay ImpDef.Clear_Ready_Queue;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ --
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ null; -- stub
+
+ if Verbose then
+ Report.Comment ("Debit_Computation in accept");
+ end if;
+
+ -- For the test:
+ if not Transaction.TC_thru_Dist then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ -- for the test: once we have completed the only Debit
+ -- message release the Credit Messages which are queued
+ -- on the Credit Input queue
+ Time_Lock.Credit_Start;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+
+ end Debit_Computation;
+
+
+begin -- C954020
+
+ Report.Test ("C954020", "Requeue, with abort, from protected entry " &
+ "to task entry");
+
+ Line_Driver.Start; -- Start the test
+
+ -- Ensure that the message tasks complete before reporting the result
+ while not (TC_Credit_Message.Complete and TC_Debit_Message.Complete) loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954020;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954021.a b/gcc/testsuite/ada/acats/tests/c9/c954021.a
new file mode 100644
index 000000000..626f2f970
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954021.a
@@ -0,0 +1,524 @@
+-- C954021.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue within a protected entry to an entry in a
+-- different protected object is queued correctly.
+--
+-- TEST DESCRIPTION:
+-- One transaction is sent through to check the paths. After processing
+-- this the Credit task sets the "overloaded" indicator. Once this
+-- indicator is set the Distributor (a protected object) queues low
+-- priority transactions on a Wait_for_Underload queue in another
+-- protected object using a requeue. The Distributor still delivers high
+-- priority transactions. After two high priority transactions have been
+-- processed by the Credit task it clears the overload condition. The
+-- low priority transactions should now be delivered.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life, dynamic
+-- and unpredictable at the time of message generation. All rerouting in
+-- this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 26 Nov 95 SAIC Fixed shared global variable for ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954021 is
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+
+ -- Mechanism to count the number of Credit Message tasks completed
+ protected TC_Tasks_Completed is
+ procedure Increment;
+ function Count return integer;
+ private
+ Number_Complete : integer := 0;
+ end TC_Tasks_Completed;
+
+
+ TC_Credit_Messages_Expected : constant integer := 5;
+
+ protected TC_Handshake is
+ procedure Set;
+ function First_Message_Arrived return Boolean;
+ private
+ Arrived_Flag : Boolean := false;
+ end TC_Handshake;
+
+ -- Handshaking mechanism between the Line Driver and the Credit task
+ --
+ protected body TC_Handshake is
+ --
+ procedure Set is
+ begin
+ Arrived_Flag := true;
+ end Set;
+ --
+ function First_Message_Arrived return Boolean is
+ begin
+ return Arrived_Flag;
+ end First_Message_Arrived;
+ --
+ end TC_Handshake;
+
+
+ protected type Shared_Boolean (Initial_Value : Boolean := False) is
+ procedure Set_True;
+ procedure Set_False;
+ function Value return Boolean;
+ private
+ Current_Value : Boolean := Initial_Value;
+ end Shared_Boolean;
+
+ protected body Shared_Boolean is
+ procedure Set_True is
+ begin
+ Current_Value := True;
+ end Set_True;
+
+ procedure Set_False is
+ begin
+ Current_Value := False;
+ end Set_False;
+
+ function Value return Boolean is
+ begin
+ return Current_Value;
+ end Value;
+ end Shared_Boolean;
+
+ TC_Debit_Message_Complete : Shared_Boolean (False);
+
+ type Transaction_Code is (Credit, Debit);
+ type Transaction_Priority is (High, Low);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Priority : Transaction_Priority := High;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Dist : Boolean := false;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ protected Distributor is
+ procedure Set_Credit_Overloaded;
+ procedure Clear_Credit_Overloaded;
+ function Credit_is_Overloaded return Boolean;
+ entry Input (Transaction : acc_Transaction_Record);
+ private
+ Credit_Overloaded : Boolean := false;
+ end Distributor;
+
+ protected Hold is
+ procedure Underloaded;
+ entry Wait_for_Underload (Transaction : acc_Transaction_Record);
+ private
+ Release_All : Boolean := false;
+ end Hold;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+ --
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ protected body Distributor is
+
+ procedure Set_Credit_Overloaded is
+ begin
+ Credit_Overloaded := true;
+ end Set_Credit_Overloaded;
+
+ procedure Clear_Credit_Overloaded is
+ begin
+ Credit_Overloaded := false;
+ Hold.Underloaded; -- Release all held messages
+ end Clear_Credit_Overloaded;
+
+ function Credit_is_Overloaded return Boolean is
+ begin
+ return Credit_Overloaded;
+ end Credit_is_Overloaded;
+
+
+ entry Input (Transaction : acc_Transaction_Record) when true is
+ -- barrier is always open
+ begin
+ -- Test Control: Set the indicator in the message to show it has
+ -- passed through the Distributor object
+ Transaction.TC_thru_Dist := true;
+
+ -- Pass this transaction on to the appropriate computation
+ -- task but temporarily hold low-priority transactions under
+ -- overload conditions
+ case Transaction.Code is
+ when Credit =>
+ if Credit_Overloaded and Transaction.Priority = Low then
+ requeue Hold.Wait_for_Underload with abort;
+ else
+ requeue Credit_Computation.Input with abort;
+ end if;
+ when Debit =>
+ requeue Debit_Computation.Input with abort;
+ end case;
+ end Input;
+ end Distributor;
+
+
+ -- Low priority Message tasks are held on the Wait_for_Underload queue
+ -- while the Credit computation system is overloaded. Once the Credit
+ -- system reached underload send all queued messages immediately
+ --
+ protected body Hold is
+
+ -- Once this is executed the barrier condition for the entry is
+ -- evaluated
+ procedure Underloaded is
+ begin
+ Release_All := true;
+ end Underloaded;
+
+ entry Wait_for_Underload (Transaction : acc_Transaction_Record)
+ when Release_All is
+ begin
+ requeue Credit_Computation.Input with abort;
+ if Wait_for_Underload'count = 0 then
+ -- Queue is purged. Set up to hold next batch
+ Release_All := false;
+ end if;
+ end Wait_for_Underload;
+
+ end Hold;
+
+ -- Mechanism to count the number of Message tasks completed (Credit)
+ protected body TC_Tasks_Completed is
+ procedure Increment is
+ begin
+ Number_Complete := Number_Complete + 1;
+ end Increment;
+
+ function Count return integer is
+ begin
+ return Number_Complete;
+ end Count;
+ end TC_Tasks_Completed;
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- The Line Driver task would normally be designed to loop continuously
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to the required number of dummy messages needed for
+ -- this test and allow it to terminate at that point. Artificially
+ -- alternate High and Low priority Credit transactions for this test.
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ Current_Priority : Transaction_Priority := High;
+
+ -- Artificial: number of messages required for this test
+ type TC_Trans_Range is range 1..6;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+ Next_Transaction.Priority := Current_Priority;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ accept Start; -- Wait for trigger from Main
+
+ for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record :=
+ new Transaction_Record;
+ begin
+ if Transaction_Numb = TC_Trans_Range'first then
+ -- Send the first Credit message
+ Build_Credit_Record ( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ -- TC: Wait until the first message has been received by the
+ -- Credit task and it has set the Overload indicator for the
+ -- Distributor
+ while not TC_Handshake.First_Message_Arrived loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ elsif Transaction_Numb = TC_Trans_Range'last then
+ -- For this test send the last transaction to the Debit task
+ -- to improve the mix
+ Build_Debit_Record( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ else
+ -- TC: Alternate high and low priority transactions
+ if Current_Priority = High then
+ Current_Priority := Low;
+ else
+ Current_Priority := High;
+ end if;
+ Build_Credit_Record( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end if;
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+
+ accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+ -- For the test check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= Credit_Return or
+ not This_Transaction.TC_thru_Dist then
+ Report.Failed ("Expected path not traversed - Credit");
+ end if;
+ TC_Tasks_Completed.Increment;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or
+ not This_Transaction.TC_thru_Dist then
+ Report.Failed ("Expected path not traversed - Debit");
+ end if;
+ TC_Debit_Message_Complete.Set_True;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+ end Message_Task;
+
+
+
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ task body Credit_Computation is
+
+ Message_Count : integer := 0;
+
+ begin
+ loop
+ select
+ accept Input ( Transaction : acc_Transaction_Record) do
+ if Distributor.Credit_is_Overloaded
+ and Transaction.Priority = Low then
+ -- We should not be getting any Low Priority messages. They
+ -- should be waiting on the Hold.Wait_for_Underload
+ -- queue
+ Report.Failed
+ ("Credit Task: Low priority transaction during overload");
+ end if;
+ -- Perform the computations required for this transaction
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_thru_Dist then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- The following is all Test Control code:
+ Transaction.Return_Value := Credit_Return;
+ Message_Count := Message_Count + 1;
+ --
+ -- Now take special action depending on which Message
+ if Message_Count = 1 then
+ -- After the first message :
+ Distributor.Set_Credit_Overloaded;
+ -- Now flag the Line_Driver that the second and subsequent
+ -- messages may now be sent
+ TC_Handshake.Set;
+ end if;
+ if Message_Count = 3 then
+ -- The two high priority transactions created subsequent
+ -- to the overload have now been processed
+ Distributor.Clear_Credit_Overloaded;
+ end if;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ --
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_thru_Dist then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+ end Debit_Computation;
+
+
+begin
+ Report.Test ("C954021", "Requeue from one entry body to an entry in" &
+ " another protected object");
+
+ Line_Driver.Start; -- Start the test
+
+
+ -- Ensure that the message tasks have completed before reporting result
+ while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected)
+ and not TC_Debit_Message_Complete.Value loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ Report.Result;
+
+end C954021;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954022.a b/gcc/testsuite/ada/acats/tests/c9/c954022.a
new file mode 100644
index 000000000..5ebff8dcb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954022.a
@@ -0,0 +1,351 @@
+-- C954022.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- In an entry body requeue the call to the same entry. Check that the
+-- items go to the right queue and that they are placed back on the end
+-- of the queue
+--
+-- TEST DESCRIPTION:
+-- Simulate part of a message handling application where the messages are
+-- composed of several segments. The sequence of the segments within the
+-- message is specified by Seg_Sequence_No. The segments are handled by
+-- different tasks and finally forwarded to an output driver. The
+-- segments can arrive in any order but must be assembled into the proper
+-- sequence for final output. There is a Sequencer task interposed
+-- before the Driver. This takes the segments of the message off the
+-- Ordering_Queue and those that are in the right order it sends on to
+-- the driver; those that are out of order it places back on the end of
+-- the queue.
+--
+-- The test just simulates the arrival of the segments at the Sequencer.
+-- The task generating the segments handshakes with the Sequencer during
+-- the "Await Arrival" phase ensuring that the three segments of a
+-- message arrive in REVERSE order (the End-of-Message segment arrives
+-- first and the Header last). In the first cycle the sequencer pulls
+-- segments off the queue and puts them back on the end till it
+-- encounters the header. It checks the sequence of the ones it pulls
+-- off in case the segments are being put back on in the wrong part of
+-- the queue. Having cycled once through it no longer verifies the
+-- sequence - it just executes the "application" code for the correct
+-- order for dispatch to the driver.
+--
+-- In this simple example no attempt is made to address segments of
+-- another message arriving or any other error conditions (such as
+-- missing segments, timing etc.)
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 07 Nov 95 SAIC ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954022 is
+
+ -- These global Booleans are set when failure conditions inside Protected
+ -- objects are encountered. Report.Failed cannot be called within
+ -- the object or a Bounded Error would occur
+ --
+ TC_Failed_1 : Boolean := false;
+ TC_Failed_2 : Boolean := false;
+ TC_Failed_3 : Boolean := false;
+
+begin
+
+
+ Report.Test ("C954022", "Check Requeue to the same Protected Entry");
+
+ declare -- encapsulate the test
+
+ type Segment_Sequence is range 1..8;
+ Header : constant Segment_Sequence := Segment_Sequence'first;
+
+ type Message_Segment is record
+ ID : integer; -- Message ID
+ Seg_Sequence_No : Segment_Sequence; -- Within the message
+ Segs_In_Message : integer; -- Total segs this message
+ EOM : Boolean := false; -- true for final msg segment
+ Alpha : string (1..128);
+ end record;
+ type acc_Message_Segment is access Message_Segment;
+
+ task TC_Simulate_Arrival;
+
+ task type Carrier_Task is
+ entry Input ( Segment : acc_Message_Segment );
+ end Carrier_Task;
+ type acc_Carrier_Task is access Carrier_Task;
+
+ protected Sequencer is
+ function TC_Arrivals return integer;
+ entry Input ( Segment : acc_Message_Segment );
+ entry Ordering_Queue ( Segment : acc_Message_Segment );
+ private
+ Number_of_Segments_Arrived : integer := 0;
+ Number_of_Segments_Expected : integer := 0;
+ Next_Needed : Segment_Sequence := Header;
+ All_Segments_Arrived : Boolean := false;
+ Seen_EOM : Boolean := false;
+
+ TC_First_Cycle : Boolean := true;
+ TC_Expected_Sequence : Segment_Sequence := Header+2;
+
+ end Sequencer;
+
+
+ task Output_Driver is
+ entry Input ( Segment : acc_Message_Segment );
+ end Output_Driver;
+
+
+ -- Simulate the arrival of three message segments in REVERSE order
+ --
+ task body TC_Simulate_Arrival is
+ begin
+ for i in 1..3 loop
+ declare
+ -- Create a task for the next message segment
+ Next_Segment_Task : acc_Carrier_Task := new Carrier_Task;
+ -- Create a record for the next segment
+ Next_Segment : acc_Message_Segment := new Message_Segment;
+ begin
+ if i = 1 then
+ -- Build the EOM segment as the first to "send"
+ Next_Segment.Seg_Sequence_No := Header + 2;
+ Next_Segment.Segs_In_Message := 3;
+ Next_Segment.EOM := true;
+ elsif i = 2 then
+ -- Wait for the first segment to arrive at the Sequencer
+ -- before "sending" the second
+ while Sequencer.TC_Arrivals < 1 loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ -- Build the segment
+ Next_Segment.Seg_Sequence_No := Header +1;
+ else
+ -- Wait for the second segment to arrive at the Sequencer
+ -- before "sending" the third
+ while Sequencer.TC_Arrivals < 2 loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ -- Build the segment. The last segment (in order) to
+ -- arrive will be the "header" segment
+ Next_Segment.Seg_Sequence_No := Header;
+ end if;
+ -- pass the record to its carrier
+ Next_Segment_Task.Input ( Next_Segment );
+ end;
+ end loop;
+
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in TC_Simulate_Arrival");
+ end TC_Simulate_Arrival;
+
+
+ -- One of these is generated for each message segment and the flow
+ -- of the segments through the system is controlled by the calls the
+ -- task makes and the requeues of those calls
+ --
+ task body Carrier_Task is
+ This_Segment : acc_Message_Segment := new Message_Segment;
+ begin
+ accept Input ( Segment : acc_Message_Segment ) do
+ This_Segment.all := Segment.all;
+ end Input;
+ null; --:: stub. Pass the segment around the application as needed
+
+ -- Now output the segment to the Output_Driver. First we have to
+ -- go through the Sequencer.
+ Sequencer.Input ( This_Segment );
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Carrier_Task");
+ end Carrier_Task;
+
+ -- Store segments on the Ordering_Queue then deliver them in the correct
+ -- sequence to the Output_Driver.
+ --
+ protected body Sequencer is
+
+ function TC_Arrivals return integer is
+ begin
+ return Number_of_Segments_Arrived;
+ end TC_Arrivals;
+
+
+ -- Segments arriving at the Input queue are counted and checked
+ -- against the total number of segments for the message. They
+ -- are requeued onto the ordering queue where they are held until
+ -- all the segments have arrived.
+ entry Input ( Segment : acc_Message_Segment ) when true is
+ begin
+ -- check for EOM, if so get the number of segments in the message
+ -- Note: in this portion of code no attempt is made to address
+ -- reset for new message , end conditions, missing segments,
+ -- segments of a different message etc.
+ Number_of_Segments_Arrived := Number_of_Segments_Arrived + 1;
+ if Segment.EOM then
+ Number_of_Segments_Expected := Segment.Segs_In_Message;
+ Seen_EOM := true;
+ end if;
+
+ if Seen_EOM then
+ if Number_of_Segments_Arrived = Number_of_Segments_Expected then
+ -- This is the last segment for this message
+ All_Segments_Arrived := true; -- clear the barrier
+ end if;
+ end if;
+
+ requeue Ordering_Queue;
+
+ -- At this exit point the entry queue barriers are evaluated
+
+ end Input;
+
+
+ entry Ordering_Queue ( Segment : acc_Message_Segment )
+ when All_Segments_Arrived is
+ begin
+
+ --=====================================================
+ -- This part is all Test_Control code
+
+ if TC_First_Cycle then
+ -- Check the order of the original three
+ if Segment.Seg_Sequence_No /= TC_Expected_Sequence then
+ -- The segments are not being pulled off in the
+ -- expected sequence. This could occur if the
+ -- requeue is not putting them back on the end.
+ TC_Failed_3 := true;
+ end if; -- sequence check
+ -- Decrement the expected sequence
+ if TC_Expected_Sequence /= Header then
+ TC_Expected_Sequence := TC_Expected_Sequence - 1;
+ else
+ TC_First_Cycle := false; -- This is the Header - the
+ -- first two segments are
+ -- back on the queue
+ end if; -- decrementing
+ end if; -- first cycle
+ --=====================================================
+
+ -- And this is the Application code
+ if Segment.Seg_Sequence_No = Next_Needed then
+ if Segment.EOM then
+ Next_Needed := Header; -- reset for next message
+ -- :: other resets not shown
+ else
+ Next_Needed := Next_Needed + 1;
+ end if;
+ requeue Output_Driver.Input with abort;
+ -- set to Report Failed - Requeue did not complete entry body
+ TC_Failed_1 := true;
+ else
+ -- Not the next needed - put it back on the queue
+ -- NOTE: here we are requeueing to the same entry
+ requeue Sequencer.Ordering_Queue;
+ -- set to Report Failed - Requeue did not complete entry body
+ TC_Failed_2 := true;
+ end if;
+ end Ordering_Queue;
+ end Sequencer;
+
+
+ task body Output_Driver is
+ This_Segment : acc_Message_Segment := new Message_Segment;
+
+ TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first;
+ TC_Segment_Total : integer := 0;
+ TC_Expected_Total : integer := 3;
+ begin
+ loop
+ -- Note: normally we would expect this Accept to be in a select
+ -- with terminate. For the test we exit the loop on completion
+ -- to give better control
+ accept Input ( Segment : acc_Message_Segment ) do
+ This_Segment.all := Segment.all;
+ end Input;
+
+ null; --::: stub - output the next segment of the message
+
+ -- The following is all test control code
+ --
+ if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then
+ Report.Failed ("Output_Driver: Segment out of sequence");
+ end if;
+ TC_Expected_Sequence := TC_Expected_Sequence + 1;
+
+ -- Now count the number of segments
+ TC_Segment_Total := TC_Segment_Total + 1;
+
+ -- Check the number and exit loop when complete
+ -- There must be exactly TC_Expected_Total in number and
+ -- the last one must be EOM
+ -- (test will hang if < TC_Expected_Total arrive
+ -- without EOM)
+ if This_Segment.EOM then
+ -- This is the last segment.
+ if TC_Segment_Total /= TC_Expected_Total then
+ Report.Failed ("EOM and wrong number of segments");
+ end if;
+ exit; -- the loop and terminate the task
+ elsif TC_Segment_Total = TC_Expected_Total then
+ Report.Failed ("No EOM found");
+ exit;
+ end if;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in Output_Driver");
+ end Output_Driver;
+
+
+ begin
+
+ null;
+
+ end; -- encapsulation
+
+ if TC_Failed_1 then
+ Report.Failed ("Requeue did not complete entry body - 1");
+ end if;
+
+ if TC_Failed_2 then
+ Report.Failed ("Requeue did not complete entry body - 2");
+ end if;
+
+ if TC_Failed_3 then
+ Report.Failed ("Sequencer: Segment out of sequence");
+ end if;
+
+ Report.Result;
+
+end C954022;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954023.a b/gcc/testsuite/ada/acats/tests/c9/c954023.a
new file mode 100644
index 000000000..bfa69dc60
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954023.a
@@ -0,0 +1,558 @@
+-- C954023.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue within a protected entry to a family of entries
+-- in a different protected object is queued correctly
+-- Call with parameters
+-- Requeue with abort
+--
+-- TEST DESCRIPTION:
+-- One transaction is sent through to check the paths. After processing
+-- this, the Credit task sets the "overloaded" indicator. Once this
+-- indicator is set the Distributor (a protected object) queues lower
+-- priority transactions on a family of queues (Wait_for_Underload) in
+-- another protected object using a requeue. The Distributor still
+-- delivers high priority transactions. After two more high priority
+-- transactions have been processed by the Credit task the artificial
+-- test code clears the overload condition to the threshold level that
+-- allows only the items on the Medium priority queue of the family to be
+-- released. When these have been processed and checked the test code
+-- then lowers the priority threshold once again, allowing the Low
+-- priority items from the last queue in the family to be released,
+-- processed and checked. Note: the High priority queue in the family is
+-- not used.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life, dynamic
+-- and unpredictable at the time of message generation. All rerouting in
+-- this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C954023 is
+
+ -- Artificial: number of messages required for this test
+ subtype TC_Trans_Range is integer range 1..8;
+
+ TC_Credit_Messages_Expected : constant integer
+ := TC_Trans_Range'Last - 1;
+
+ TC_Debit_Message_Complete : Boolean := false;
+
+
+ -- Mechanism for handshaking between tasks
+ protected TC_PO is
+ procedure Increment_Tasks_Completed_Count;
+ function Tasks_Completed_Count return integer;
+ function First_Message_Has_Arrived return Boolean;
+ procedure Set_First_Message_Has_Arrived;
+ private
+ Number_Complete : integer := 0;
+ Message_Arrived_Flag : Boolean := false;
+ end TC_PO;
+ --
+ protected body TC_PO is
+ procedure Increment_Tasks_Completed_Count is
+ begin
+ Number_Complete := Number_Complete + 1;
+ end Increment_Tasks_Completed_Count;
+
+ function Tasks_Completed_Count return integer is
+ begin
+ return Number_Complete;
+ end Tasks_Completed_Count;
+
+ function First_Message_Has_Arrived return Boolean is
+ begin
+ return Message_Arrived_Flag;
+ end First_Message_Has_Arrived;
+
+ procedure Set_First_Message_Has_Arrived is
+ begin
+ Message_Arrived_Flag := true;
+ end Set_First_Message_Has_Arrived;
+
+ end TC_PO;
+
+begin
+
+ Report.Test ("C954023", "Requeue from within a protected object" &
+ " to a family of entries in another protected object");
+
+
+ declare -- encapsulate the test
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+ type Transaction_Code is (Credit, Debit);
+ type App_Priority is (Low, Medium, High);
+ type Priority_Block is array (App_Priority) of Boolean;
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Priority : App_Priority := High;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Distrib : Boolean := false;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ protected Distributor is
+ procedure Set_Credit_Overloaded;
+ procedure Clear_Overload_to_Medium;
+ procedure Clear_Overload_to_Low;
+ entry Input (Transaction : acc_Transaction_Record);
+ private
+ Credit_Overloaded : Boolean := false;
+ end Distributor;
+
+ protected Hold is
+ procedure Release_Medium;
+ procedure Release_Low;
+ -- Family of entry queues indexed by App_Priority
+ entry Wait_for_Underload (App_Priority)
+ (Transaction : acc_Transaction_Record);
+ private
+ Release : Priority_Block := (others => false);
+ end Hold;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+ --
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ protected body Distributor is
+
+ procedure Set_Credit_Overloaded is
+ begin
+ Credit_Overloaded := true;
+ end Set_Credit_Overloaded;
+
+ procedure Clear_Overload_to_Medium is
+ begin
+ Credit_Overloaded := false;
+ Hold.Release_Medium; -- Release all held messages on Medium
+ -- priority queue
+ end Clear_Overload_to_Medium;
+
+ procedure Clear_Overload_to_Low is
+ begin
+ Credit_Overloaded := false;
+ Hold.Release_Low; -- Release all held messages on Low
+ -- priority queue
+ end Clear_Overload_to_Low;
+
+
+
+ entry Input (Transaction : acc_Transaction_Record) when true is
+ -- barrier is always open
+ begin
+ -- Test Control: Set the indicator in the message to show it has
+ -- passed through the Distributor object
+ Transaction.TC_thru_Distrib := true;
+
+ -- Pass this transaction on to the appropriate computation
+ -- task but temporarily hold low-priority transactions under
+ -- overload conditions
+ case Transaction.Code is
+ when Credit =>
+ if Credit_Overloaded and Transaction.Priority /= High then
+ -- use the appropriate queue in the family
+ requeue Hold.Wait_for_Underload(Transaction.Priority)
+ with abort;
+ else
+ requeue Credit_Computation.Input with abort;
+ end if;
+ when Debit =>
+ requeue Debit_Computation.Input with abort;
+ end case;
+ end Input;
+ end Distributor;
+
+
+ -- Low priority Message tasks are held on the Wait_for_Underload queue
+ -- while the Credit computation system is overloaded. Once the Credit
+ -- system reached underload send all queued messages immediately
+ --
+ protected body Hold is
+
+ -- Once these are executed the barrier conditions for the entries
+ -- are evaluated
+ procedure Release_Medium is
+ begin
+ Release(Medium) := true;
+ end Release_Medium;
+ --
+ procedure Release_Low is
+ begin
+ Release(Low) := true;
+ end Release_Low;
+
+ -- This is a family of entry queues indexed by App_Priority
+ entry Wait_for_Underload (for AP in App_Priority)
+ (Transaction : acc_Transaction_Record)
+ when Release(AP) is
+ begin
+ requeue Credit_Computation.Input with abort;
+ if Wait_for_Underload(AP)'count = 0 then
+ -- Queue is purged. Set up to hold next batch
+ Release(AP) := false;
+ end if;
+ end Wait_for_Underload;
+
+ end Hold;
+
+
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- The Line Driver task would normally be designed to loop
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to the required number of dummy messages needed for
+ -- this test and allow it to terminate at that point. Artificially
+ -- cycle the generation of High medium and Low priority Credit
+ -- transactions for this test. Send out one final Debit message
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ Current_Priority : App_Priority := High;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+ Next_Transaction.Priority := Current_Priority;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record :=
+ new Transaction_Record;
+ begin
+ if Transaction_Numb = TC_Trans_Range'first then
+ -- Send the first Credit message
+ Build_Credit_Record ( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ -- TC: Wait until the first message has been received by the
+ -- Credit task and it has set the Overload indicator for the
+ -- Distributor
+ while not TC_PO.First_Message_Has_Arrived loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ elsif Transaction_Numb = TC_Trans_Range'last then
+ -- For this test send the last transaction to the Debit task
+ -- to improve the mix
+ Build_Debit_Record( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ else
+ -- TC: Cycle generation of high medium and low priority
+ -- transactions
+ if Current_Priority = High then
+ Current_Priority := Medium;
+ elsif
+ Current_Priority = Medium then
+ Current_Priority := Low;
+ else
+ Current_Priority := High;
+ end if;
+ Build_Credit_Record( Next_Transaction );
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end if;
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+
+ accept Accept_Transaction(In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+ -- For the test check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= Credit_Return or
+ not This_Transaction.TC_thru_Distrib then
+ Report.Failed ("Expected path not traversed - Credit");
+ end if;
+ TC_PO.Increment_Tasks_Completed_Count;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or
+ not This_Transaction.TC_thru_Distrib then
+ Report.Failed ("Expected path not traversed - Debit");
+ end if;
+ TC_Debit_Message_Complete := true;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+ end Message_Task;
+
+
+
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ task body Credit_Computation is
+
+ Message_Count : integer := 0;
+
+ begin
+ loop
+ select
+ accept Input ( Transaction : acc_Transaction_Record) do
+
+ -- Perform the computations required for this transaction
+ null; -- stub
+
+
+ -- The following is all Test Control code:
+
+ if not Transaction.TC_thru_Distrib then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- This is checked by the Message_Task:
+ Transaction.Return_Value := Credit_Return;
+
+ -- Now take special action depending on which Message.
+ -- Note: The count gives the order in which the messages are
+ -- arriving at this task NOT the order in which they
+ -- were originally generated and sent out.
+
+ Message_Count := Message_Count + 1;
+
+ if Message_Count < 4 then
+ -- This is one of the first three messages which must
+ -- be High priority because we will set "Overload" after
+ -- the first, which is known to be High. The lower
+ -- priority should be waiting on the queues
+ if Transaction.Priority /= High then
+ Report.Failed
+ ("Credit Task: Lower priority trans. during overload");
+ end if;
+ if Message_Count = 1 then
+ -- After the first message :
+ Distributor.Set_Credit_Overloaded;
+ -- Now flag the Line_Driver that the second and
+ -- subsequent messages may now be sent
+ TC_PO.Set_First_Message_Has_Arrived;
+ elsif
+ Message_Count = 3 then
+ -- The two high priority transactions created
+ -- subsequent to the overload have now been processed,
+ -- release the Medium priority items
+ Distributor.Clear_Overload_to_Medium;
+ end if;
+ elsif Message_Count < 6 then
+ -- This must be one of the Medium priority messages
+ if Transaction.Priority /= Medium then
+ Report.Failed
+ ("Credit Task: Second group not Medium Priority");
+ end if;
+ if Message_Count = 5 then
+ -- The two medium priority transactions
+ -- have now been processed - release the
+ -- Low priority items
+ Distributor.Clear_Overload_to_Low;
+ end if;
+ elsif Message_Count < TC_Trans_Range'Last then
+ -- This must be one of the Low priority messages
+ if Transaction.Priority /= Low then
+ Report.Failed
+ ("Credit Task: Third group not Low Priority");
+ end if;
+ else
+ -- Too many transactions have arrived. Duplicates?
+ -- the Debit transaction?
+ Report.Failed
+ ("Credit Task: Too many transactions");
+ end if;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task. After the computation is performed the rendezvous
+ -- in the original message task is completed.
+ --
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_thru_Distrib then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+ end Debit_Computation;
+
+
+ begin -- declare
+
+ null;
+
+ end; -- declare (test encapsulation)
+
+ if (TC_PO.Tasks_Completed_Count /= TC_Credit_Messages_Expected)
+ and not TC_Debit_Message_Complete then
+ Report.Failed ("Incorrect number of Message Tasks completed");
+ end if;
+
+ Report.Result;
+
+end C954023;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954024.a b/gcc/testsuite/ada/acats/tests/c9/c954024.a
new file mode 100644
index 000000000..7f19a8183
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954024.a
@@ -0,0 +1,380 @@
+-- C954024.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a call to a protected entry can be requeued to a task
+-- entry. Check that the requeue is placed on the correct entry; that the
+-- original caller waits for the completion of the requeue and continues
+-- after the requeued rendezvous. Check that the requeue does not block.
+-- Specifically, check a requeue without abort from a protected entry to
+-- an entry in a task.
+--
+-- TEST DESCRIPTION:
+-- In the Distributor protected object, requeue two successive calls on
+-- the entries of two separate target tasks. Each task in each of the
+-- paths adds identifying information in the transaction being passed.
+-- This information is checked by the Message tasks on completion
+-- ensuring that the requeues have been placed on the correct queues.
+-- There is an artificial guard on the Credit Task to ensure that the
+-- input is queued; this guard is released by the Debit task which
+-- handles its input immediately. This ensures that we have one of the
+-- requeued items actually queued for later handling and also verifies
+-- that the requeuing process (in the protected object) is not blocked.
+--
+-- This series of tests uses a simulation of a transaction driven
+-- processing system. Line Drivers accept input from an external source
+-- and build them into transaction records. These records are then
+-- encapsulated in message tasks which remain extant for the life of the
+-- transaction in the system. The message tasks put themselves on the
+-- input queue of a Distributor object which, from information in the
+-- transaction and/or system load conditions forwards them to other
+-- operating tasks. These in turn might forward the transactions to yet
+-- other tasks for further action. The routing is, in real life,
+-- dynamic and unpredictable at the time of message generation. All
+-- rerouting in this model is done by means of requeues.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 08 Nov 95 SAIC Fixed reported problems for ACVC 2.0.1
+--
+--!
+
+with Report;
+with ImpDef;
+procedure C954024 is
+
+
+begin -- C954024
+
+ Report.Test ("C954024", "Requeue from protected entry to task entry");
+
+ declare -- encapsulate the test
+
+ -- Arbitrary test values
+ Credit_Return : constant := 1;
+ Debit_Return : constant := 2;
+
+ type Transaction_Code is (Credit, Debit);
+
+ type Transaction_Record;
+ type acc_Transaction_Record is access Transaction_Record;
+ type Transaction_Record is
+ record
+ ID : integer := 0;
+ Code : Transaction_Code := Debit;
+ Account_Number : integer := 0;
+ Stock_Number : integer := 0;
+ Quantity : integer := 0;
+ Return_Value : integer := 0;
+ TC_Message_Count : integer := 0;
+ TC_Thru_Dist : Boolean := false;
+ end record;
+
+
+ task type Message_Task is
+ entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
+ end Message_Task;
+ type acc_Message_Task is access Message_Task;
+
+ task Line_Driver is
+ entry Start;
+ end Line_Driver;
+
+ task Credit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Credit_Computation;
+
+ task Debit_Computation is
+ entry Input(Transaction : acc_Transaction_Record);
+ end Debit_Computation;
+
+ protected Time_Lock is
+ procedure Credit_Start;
+ function Credit_Enabled return Boolean;
+ private
+ Credit_OK : Boolean := false;
+ end Time_Lock;
+
+ protected body Time_Lock is
+ procedure Credit_Start is
+ begin
+ Credit_OK := true;
+ end Credit_Start;
+
+ function Credit_Enabled return Boolean is
+ begin
+ return Credit_OK;
+ end Credit_Enabled;
+ end Time_Lock;
+
+
+
+ protected Distributor is
+ entry Input (Transaction : acc_Transaction_Record);
+ end Distributor;
+ --
+ --
+ -- Dispose each input Transaction_Record to the appropriate
+ -- computation tasks
+ --
+ protected body Distributor is
+ entry Input (Transaction : acc_Transaction_Record) when true is
+ -- barrier is always open
+ begin
+ -- Test Control: Set the indicator in the message to show it has
+ -- passed through the Distributor object
+ Transaction.TC_thru_Dist := true;
+
+ -- Pass this transaction on to the appropriate computation
+ -- task
+ case Transaction.Code is
+ when Credit =>
+ requeue Credit_Computation.Input;
+ when Debit =>
+ requeue Debit_Computation.Input;
+ end case;
+ end Input;
+ end Distributor;
+
+
+
+
+ -- Assemble messages received from an external source
+ -- Creates a message task for each. The message tasks remain extant
+ -- for the life of the messages in the system.
+ -- NOTE:
+ -- The Line Driver task would normally be designed to loop continuously
+ -- creating the messages as input is received. Simulate this
+ -- but limit it to two dummy messages for this test and allow it
+ -- to terminate at that point
+ --
+ task body Line_Driver is
+ Current_ID : integer := 1;
+ TC_Last_was_for_credit : Boolean := false;
+
+ procedure Build_Credit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 100;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Credit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Credit_Record;
+
+
+ procedure Build_Debit_Record
+ ( Next_Transaction : acc_Transaction_Record ) is
+ Dummy_Account : constant integer := 200;
+ begin
+ Next_Transaction.ID := Current_ID;
+ Next_Transaction.Code := Debit;
+
+ Next_Transaction.Account_Number := Dummy_Account;
+ Current_ID := Current_ID + 1;
+ end Build_Debit_Record;
+
+ begin
+
+ accept Start; -- Wait for trigger from Main
+
+ for i in 1..2 loop -- arbitrarily limit to two messages for the test
+ declare
+ -- Create a task for the next message
+ Next_Message_Task : acc_Message_Task := new Message_Task;
+ -- Create a record for it
+ Next_Transaction : acc_Transaction_Record
+ := new Transaction_Record;
+ begin
+ if TC_Last_was_for_credit then
+ Build_Debit_Record ( Next_Transaction );
+ else
+ Build_Credit_Record( Next_Transaction );
+ TC_Last_was_for_credit := true;
+ end if;
+ Next_Message_Task.Accept_Transaction ( Next_Transaction );
+ end; -- declare
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Line_Driver");
+ end Line_Driver;
+
+
+
+
+ task body Message_Task is
+
+ TC_Original_Transaction_Code : Transaction_Code;
+ This_Transaction : acc_Transaction_Record := new Transaction_Record;
+
+ begin
+ accept Accept_Transaction
+ (In_Transaction : acc_Transaction_Record) do
+ This_Transaction.all := In_Transaction.all;
+ end Accept_Transaction;
+
+ -- Note the original code to ensure correct return
+ TC_Original_Transaction_Code := This_Transaction.Code;
+
+ -- Queue up on Distributor's Input queue
+ Distributor.Input ( This_Transaction );
+ -- This task will now wait for the requeued rendezvous
+ -- to complete before proceeding
+
+ -- After the required computations have been performed
+ -- return the Transaction_Record appropriately (probably to an output
+ -- line driver)
+ null; -- stub
+
+
+ -- The following is all Test Control Code
+
+ -- Check that the return values are as expected
+ if TC_Original_Transaction_Code /= This_Transaction.Code then
+ -- Incorrect rendezvous
+ Report.Failed ("Message Task: Incorrect code returned");
+ end if;
+
+ if This_Transaction.Code = Credit then
+ if This_Transaction.Return_Value /= Credit_Return or
+ This_Transaction.TC_Message_Count /= 1 or
+ not This_Transaction.TC_thru_Dist then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ else
+ if This_Transaction.Return_Value /= Debit_Return or
+ This_Transaction.TC_Message_Count /= 1 or
+ not This_Transaction.TC_thru_Dist then
+ Report.Failed ("Expected path not traversed");
+ end if;
+ end if;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Message_Task");
+
+ end Message_Task;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ --
+ task body Credit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ when Time_Lock.Credit_enabled =>
+ accept Input ( Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this transaction
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_thru_Dist then
+ Report.Failed
+ ("Credit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Credit then
+ Report.Failed
+ ("Credit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Credit_Return;
+ -- one, and only one message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ end Input;
+ exit; -- one message is enough
+ else
+ delay ImpDef.Clear_Ready_Queue; -- poll
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Credit_Computation");
+ end Credit_Computation;
+
+
+
+ -- Computation task.
+ -- Note: After the computation is performed in this task and the
+ -- accept body is completed the rendezvous in the original
+ -- message task is completed.
+ --
+ task body Debit_Computation is
+ Message_Count : integer := 0;
+ begin
+ loop
+ select
+ accept Input (Transaction : acc_Transaction_Record) do
+ -- Perform the computations required for this message
+ null; -- stub
+
+ -- For the test:
+ if not Transaction.TC_thru_Dist then
+ Report.Failed
+ ("Debit Task: Wrong queue, Distributor bypassed");
+ end if;
+ if Transaction.code /= Debit then
+ Report.Failed
+ ("Debit Task: Requeue delivered to the wrong queue");
+ end if;
+
+ -- for the test plug a known value and count
+ Transaction.Return_Value := Debit_Return;
+ -- one, and only one, message should pass through
+ Message_Count := Message_Count + 1;
+ Transaction.TC_Message_Count := Message_Count;
+ -- for the test: once we have completed the only Debit
+ -- message release the Credit Messages which are queued
+ -- on the Credit Input queue
+ Time_Lock.Credit_Start;
+
+ end Input;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Debit_Computation");
+
+ end Debit_Computation;
+
+ begin -- declare block
+ Line_Driver.Start;
+ end; -- test encapsulation
+
+ Report.Result;
+
+end C954024;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954025.a b/gcc/testsuite/ada/acats/tests/c9/c954025.a
new file mode 100644
index 000000000..c4993f7ed
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954025.a
@@ -0,0 +1,237 @@
+-- C954025.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if the original entry call was a conditional entry call,
+-- the call is cancelled if a requeue-with-abort of the call is not
+-- selected immediately.
+-- Check that if the original entry call was a timed entry call, the
+-- expiration time for a requeue-with-abort is the original expiration
+-- time.
+--
+-- TEST DESCRIPTION:
+-- This test declares two tasks: Launch_Control and Mission_Control.
+-- Mission_Control instructs Launch_Control to start its countdown
+-- and then requeues (with abort) to the Launch_Control.Launch
+-- entry. This call to Launch will be accepted at the end of the
+-- countdown (if the task is still waiting).
+-- The main task does an unconditional, conditional, and timed
+-- entry call to Mission_Control and checks to see if the launch
+-- was accepted.
+--
+--
+-- CHANGE HISTORY:
+-- 18 OCT 95 SAIC ACVC 2.1
+-- 10 JUL 96 SAIC Incorporated reviewer's comments.
+--
+--!
+
+with Calendar; use type Calendar.Time;
+with Report;
+with ImpDef;
+procedure C954025 is
+ Verbose : constant Boolean := False;
+ Countdown_Amount : constant Duration := 2.0 * Impdef.One_Long_Second;
+ Plenty_Of_Time : constant Duration :=
+ Countdown_Amount + ImpDef.Clear_Ready_Queue + 1.0 * Impdef.One_Long_Second;
+ Not_Enough_Time : constant Duration :=
+ Countdown_Amount - 0.5 * Impdef.One_Long_Second;
+begin
+ Report.Test ("C954025",
+ "Check that if the original entry" &
+ " call was a conditional or timed entry call, the" &
+ " expiration time for a requeue with abort is the" &
+ " original expiration time");
+ declare
+ -- note that the following object is a shared object and its use
+ -- governed by the rules of 9.10(3,4,8);6.0
+ Launch_Accepted : Boolean := False;
+
+ task Launch_Control is
+ entry Enable_Launch_Control;
+ entry Start_Countdown (How_Long : Duration);
+ -- Launch will be accepted if a call is waiting when the countdown
+ -- reaches 0
+ entry Launch;
+ end Launch_Control;
+
+ task body Launch_Control is
+ Wait_Amount : Duration := 0.0;
+ begin
+ loop
+ select
+ accept Enable_Launch_Control do
+ Launch_Accepted := False;
+ end Enable_Launch_Control;
+ or
+ terminate;
+ end select;
+
+ accept Start_Countdown (How_Long : Duration) do
+ Wait_Amount := How_Long;
+ end Start_Countdown;
+
+ delay Wait_Amount;
+
+ select
+ accept Launch do
+ Launch_Accepted := True;
+ end Launch;
+ else
+ null;
+ -- note that Launch_Accepted is False here
+ end select;
+ end loop;
+ end Launch_Control;
+
+ task Mission_Control is
+ -- launch will occur if we are given enough time to complete
+ -- a standard countdown. We will not be rushed!
+ entry Do_Launch;
+ end Mission_Control;
+
+ task body Mission_Control is
+ begin
+ loop
+ select
+ accept Do_Launch do
+ Launch_Control.Start_Countdown (Countdown_Amount);
+ requeue Launch_Control.Launch with abort;
+ end Do_Launch;
+ or
+ terminate;
+ end select;
+ end loop;
+ end Mission_Control;
+
+ begin -- test encapsulation
+ -- unconditional entry call to check the simple case
+ Launch_Control.Enable_Launch_Control;
+ Mission_Control.Do_Launch;
+ if Launch_Accepted then
+ if Verbose then
+ Report.Comment ("simple case passed");
+ end if;
+ else
+ Report.Failed ("simple case");
+ end if;
+
+
+ -- timed but with plenty of time - delay relative
+ Launch_Control.Enable_Launch_Control;
+ select
+ Mission_Control.Do_Launch;
+ or
+ delay Plenty_Of_Time;
+ if Launch_Accepted then
+ Report.Failed ("plenty of time timed out after accept (1)");
+ end if;
+ end select;
+ if Launch_Accepted then
+ if Verbose then
+ Report.Comment ("plenty of time case passed (1)");
+ end if;
+ else
+ Report.Failed ("plenty of time (1)");
+ end if;
+
+
+ -- timed but with plenty of time -- delay until
+ Launch_Control.Enable_Launch_Control;
+ select
+ Mission_Control.Do_Launch;
+ or
+ delay until Calendar.Clock + Plenty_Of_Time;
+ if Launch_Accepted then
+ Report.Failed ("plenty of time timed out after accept(2)");
+ end if;
+ end select;
+ if Launch_Accepted then
+ if Verbose then
+ Report.Comment ("plenty of time case passed (2)");
+ end if;
+ else
+ Report.Failed ("plenty of time (2)");
+ end if;
+
+
+ -- timed without enough time - delay relative
+ Launch_Control.Enable_Launch_Control;
+ select
+ Mission_Control.Do_Launch;
+ Report.Failed ("not enough time completed accept (1)");
+ or
+ delay Not_Enough_Time;
+ end select;
+ if Launch_Accepted then
+ Report.Failed ("not enough time (1)");
+ else
+ if Verbose then
+ Report.Comment ("not enough time case passed (1)");
+ end if;
+ end if;
+
+
+ -- timed without enough time - delay until
+ Launch_Control.Enable_Launch_Control;
+ select
+ Mission_Control.Do_Launch;
+ Report.Failed ("not enough time completed accept (2)");
+ or
+ delay until Calendar.Clock + Not_Enough_Time;
+ end select;
+ if Launch_Accepted then
+ Report.Failed ("not enough time (2)");
+ else
+ if Verbose then
+ Report.Comment ("not enough time case passed (2)");
+ end if;
+ end if;
+
+
+ -- conditional case
+ Launch_Control.Enable_Launch_Control;
+ -- make sure Mission_Control is ready to accept immediately
+ delay ImpDef.Clear_Ready_Queue;
+ select
+ Mission_Control.Do_Launch;
+ Report.Failed ("no time completed accept");
+ else
+ if Verbose then
+ Report.Comment ("conditional case - else taken");
+ end if;
+ end select;
+ if Launch_Accepted then
+ Report.Failed ("no time");
+ else
+ if Verbose then
+ Report.Comment ("no time case passed");
+ end if;
+ end if;
+
+ end;
+
+ Report.Result;
+end C954025;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954026.a b/gcc/testsuite/ada/acats/tests/c9/c954026.a
new file mode 100644
index 000000000..9e261247b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954026.a
@@ -0,0 +1,269 @@
+-- C954026.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if the original protected entry call was a conditional
+-- entry call, the call is cancelled if a requeue-with-abort of the
+-- call is not selected immediately.
+-- Check that if the original protected entry call was a timed entry
+-- call, the expiration time for a requeue-with-abort is the original
+-- expiration time.
+--
+-- TEST DESCRIPTION:
+-- In this test the main task makes a variety of calls to the protected
+-- object Initial_PO. These calls include a simple call, a conditional
+-- call, and a timed call. The timed calls include calls with enough
+-- time and those with less than the needed amount of time to get through
+-- the requeue performed by Initial_PO.
+-- Initial_PO requeues its entry call to Final_PO.
+-- Final_PO does not accept the requeued call until the protected
+-- procedure Ok_To_Take_Requeue is called.
+-- A separate task, Delayed_Opener, is used to call Ok_To_Take_Requeue
+-- after a delay amount specified by the main task has expired.
+--
+--
+-- CHANGE HISTORY:
+-- 15 DEC 95 SAIC ACVC 2.1
+-- 10 JUL 96 SAIC Incorporated reviewer comments.
+-- 10 OCT 96 SAIC Incorporated fix provided by vendor.
+--
+--!
+
+with Calendar;
+use type Calendar.Time;
+with Report;
+with Impdef;
+procedure C954026 is
+ Verbose : constant Boolean := False;
+ Final_Po_Reached : Boolean := False;
+ Allowed_Time : constant Duration := 2.0 * Impdef.One_Long_Second;
+ Plenty_Of_Time : constant Duration :=
+ Allowed_Time + Impdef.Clear_Ready_Queue + 1.0 * Impdef.One_Long_Second;
+ Not_Enough_Time : constant Duration := Allowed_Time - 0.5 * Impdef.One_Long_Second;
+begin
+ Report.Test ("C954026",
+ "Check that if the original entry" &
+ " call was a conditional or timed entry call," &
+ " the expiration time for a requeue with" &
+ " abort to a protected" &
+ " entry is the original expiration time");
+ declare
+
+ protected Initial_Po is
+ entry Start_Here;
+ end Initial_Po;
+
+ protected Final_Po is
+ entry Requeue_Target;
+ procedure Ok_To_Take_Requeue;
+ procedure Close_Requeue;
+ private
+ Open : Boolean := False;
+ end Final_Po;
+
+ -- the Delayed_Opener task is used to notify Final_PO that it can
+ -- accept the Requeue_Target entry.
+ task Delayed_Opener is
+ entry Start_Timer (Amt : Duration);
+ entry Cancel_Timer;
+ end Delayed_Opener;
+
+ task body Delayed_Opener is
+ Wait_Amt : Duration;
+ begin
+ loop
+ accept Start_Timer (Amt : Duration) do
+ Wait_Amt := Amt;
+ end Start_Timer;
+ exit when Wait_Amt < 0.0;
+ if Verbose then
+ Report.Comment ("Timer started");
+ end if;
+ select
+ accept Cancel_Timer do
+ Final_Po.Close_Requeue;
+ end Cancel_Timer;
+ or
+ delay Wait_Amt;
+ Final_Po.Ok_To_Take_Requeue;
+ accept Cancel_Timer do
+ Final_Po.Close_Requeue;
+ end Cancel_Timer;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("exception in Delayed_Opener");
+ end Delayed_Opener;
+
+ protected body Initial_Po is
+ entry Start_Here when True is
+ begin
+ Final_Po_Reached := False;
+ requeue Final_Po.Requeue_Target with abort;
+ end Start_Here;
+ end Initial_Po;
+
+ protected body Final_Po is
+ entry Requeue_Target when Open is
+ begin
+ Open := False;
+ Final_Po_Reached := True;
+ end Requeue_Target;
+
+ procedure Ok_To_Take_Requeue is
+ begin
+ Open := True;
+ end Ok_To_Take_Requeue;
+
+ procedure Close_Requeue is
+ begin
+ Open := False;
+ end Close_Requeue;
+ end Final_Po;
+
+ begin -- test encapsulation
+ -- unconditional entry call to check the simple case
+ Delayed_Opener.Start_Timer (0.0);
+ Initial_Po.Start_Here;
+ if Final_Po_Reached then
+ if Verbose then
+ Report.Comment ("simple case passed");
+ end if;
+ else
+ Report.Failed ("simple case");
+ end if;
+ Delayed_Opener.Cancel_Timer;
+
+
+ -- timed but with plenty of time - delay relative
+ Delayed_Opener.Start_Timer (Allowed_Time);
+ select
+ Initial_Po.Start_Here;
+ or
+ delay Plenty_Of_Time;
+ Report.Failed ("plenty of time timed out (1)");
+ if Final_Po_Reached then
+ Report.Failed (
+ "plenty of time timed out after accept (1)");
+ end if;
+ end select;
+ if Final_Po_Reached then
+ if Verbose then
+ Report.Comment ("plenty of time case passed (1)");
+ end if;
+ else
+ Report.Failed ("plenty of time (1)");
+ end if;
+ Delayed_Opener.Cancel_Timer;
+
+
+ -- timed but with plenty of time -- delay until
+ Delayed_Opener.Start_Timer (Allowed_Time);
+ select
+ Initial_Po.Start_Here;
+ or
+ delay until Calendar.Clock + Plenty_Of_Time;
+ Report.Failed ("plenty of time timed out (2)");
+ if Final_Po_Reached then
+ Report.Failed (
+ "plenty of time timed out after accept(2)");
+ end if;
+ end select;
+ if Final_Po_Reached then
+ if Verbose then
+ Report.Comment ("plenty of time case passed (2)");
+ end if;
+ else
+ Report.Failed ("plenty of time (2)");
+ end if;
+ Delayed_Opener.Cancel_Timer;
+
+
+ -- timed without enough time - delay relative
+ Delayed_Opener.Start_Timer (Allowed_Time);
+ select
+ Initial_Po.Start_Here;
+ Report.Failed ("not enough time completed accept (1)");
+ or
+ delay Not_Enough_Time;
+ end select;
+ if Final_Po_Reached then
+ Report.Failed ("not enough time (1)");
+ else
+ if Verbose then
+ Report.Comment ("not enough time case passed (1)");
+ end if;
+ end if;
+ Delayed_Opener.Cancel_Timer;
+
+
+ -- timed without enough time - delay until
+ Delayed_Opener.Start_Timer (Allowed_Time);
+ select
+ Initial_Po.Start_Here;
+ Report.Failed ("not enough time completed accept (2)");
+ or
+ delay until Calendar.Clock + Not_Enough_Time;
+ end select;
+ if Final_Po_Reached then
+ Report.Failed ("not enough time (2)");
+ else
+ if Verbose then
+ Report.Comment ("not enough time case passed (2)");
+ end if;
+ end if;
+ Delayed_Opener.Cancel_Timer;
+
+
+ -- conditional case
+ Delayed_Opener.Start_Timer (Allowed_Time);
+ select
+ Initial_Po.Start_Here;
+ Report.Failed ("no time completed accept");
+ else
+ if Verbose then
+ Report.Comment ("conditional case - else taken");
+ end if;
+ end select;
+ if Final_Po_Reached then
+ Report.Failed ("no time");
+ else
+ if Verbose then
+ Report.Comment ("no time case passed");
+ end if;
+ end if;
+ Delayed_Opener.Cancel_Timer;
+
+ -- kill off the Delayed_Opener task
+ Delayed_Opener.Start_Timer (-10.0);
+
+ exception
+ when others =>
+ Report.Failed ("exception in main");
+ end;
+
+ Report.Result;
+end C954026;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a01.a b/gcc/testsuite/ada/acats/tests/c9/c954a01.a
new file mode 100644
index 000000000..3ea545a8f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954a01.a
@@ -0,0 +1,262 @@
+-- C954A01.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if a task requeued without abort on a protected entry queue
+-- is aborted, the abort is deferred until the entry call completes,
+-- after which the task becomes completed.
+--
+-- TEST DESCRIPTION:
+-- Declare a protected type which simulates a printer device driver
+-- (foundation code).
+--
+-- Declare a task which simulates a printer server for multiple printers.
+--
+-- For the protected type, declare an entry with a barrier that is set
+-- false by a protected procedure (which simulates starting a print job
+-- on the printer), and is set true by a second protected procedure (which
+-- simulates a handler called when the printer interrupts, indicating
+-- that printing is done).
+--
+-- For the task, declare an entry whose corresponding accept statement
+-- contains a call to first protected procedure of the protected type
+-- (which sets the barrier of the protected entry to false), followed by
+-- a requeue with abort to the protected entry. Declare a second entry
+-- which does nothing.
+--
+-- Declare a "requesting" task which calls the printer server task entry
+-- (and thus executes the requeue). Attempt to abort the requesting
+-- task. Verify that it is not aborted. Call the second protected
+-- procedure of the protected type (the interrupt handler) and verify that
+-- the protected entry completes for the requesting task. Verify that
+-- the requesting task is then aborted.
+--
+-- TEST FILES:
+-- This test depends on the following foundation code:
+--
+-- F954A00.A
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 10 Oct 96 SAIC Added pragma elaborate.
+--
+--!
+
+package C954A01_0 is -- Printer server abstraction.
+
+ -- Simulate a system with multiple printers. The entry Print requests
+ -- that data be printed on the next available printer. The entry call
+ -- is accepted when a printer is available, and completes when printing
+ -- is done.
+
+
+ task Printer_Server is
+ entry Print (File_Name : String); -- Test the requeue statement.
+ entry Verify_Results; -- Artifice for test purposes.
+ end Printer_Server;
+
+end C954A01_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with F954A00; -- Printer device abstraction.
+use F954A00;
+pragma Elaborate(F954A00);
+
+package body C954A01_0 is -- Printer server abstraction.
+
+ task body Printer_Server is
+ Printers_Busy : Boolean := True;
+ Index : Printer_ID := 1;
+ Print_Accepted : Boolean := False;
+ begin
+
+ loop
+ -- Wait for a printer to become available:
+
+ while Printers_Busy loop
+ Printers_Busy := False; -- Exit loop if
+ -- entry accepted.
+ select
+ Printer(Index).Done_Printing; -- Accepted immed.
+ -- when printer is
+ -- available.
+ else
+ Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed.
+ Printers_Busy := True; -- accepted; keep
+ end select; -- looping.
+ end loop;
+ -- Value of Index
+ -- at loop exit
+ -- identifies the
+ -- avail. printer.
+
+ -- Wait for a print request or terminate:
+
+ select
+ accept Print (File_Name : String) do
+ Print_Accepted := True; -- Allow
+ -- Verify_Results
+ -- to be accepted.
+
+ Printer(Index).Start_Printing (File_Name); -- Begin printing on
+ -- the available
+ -- -- -- printer.
+ -- Requeue is tested here --
+ -- --
+ -- Requeue caller so
+ requeue Printer(Index).Done_Printing; -- server task free
+ -- to accept other
+ end Print; -- requests.
+ or
+ -- Guard ensures that Verify_Results cannot be accepted
+ -- until after Print has been accepted. This avoids a
+ -- race condition in the main program.
+
+ when Print_Accepted => accept Verify_Results; -- Artifice for
+ -- testing purposes.
+ or
+ terminate;
+ end select;
+
+ -- Allow other tasks to get control
+ delay ImpDef.Long_Minimum_Task_Switch;
+
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Exception raised in Printer_Server task");
+ end Printer_Server;
+
+
+end C954A01_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with F954A00; -- Printer device abstraction.
+with C954A01_0; -- Printer server abstraction.
+
+use C954A01_0;
+use F954A00;
+
+procedure C954A01 is
+
+ Long_Enough : constant Duration := ImpDef.Long_Switch_To_New_Task;
+
+ --==============================================--
+
+ task Print_Request; -- Send a print request.
+
+ task body Print_Request is
+ My_File : constant String := "MYFILE.DAT";
+ begin
+ Printer_Server.Print (My_File); -- Invoke requeue statement.
+ Report.Failed ("Task continued execution following entry call");
+ exception
+ when others =>
+ Report.Failed ("Exception raised in Print_Request task");
+ end Print_Request;
+
+ --==============================================--
+
+begin -- Main program.
+
+ Report.Test ("C954A01", "Requeue without abort - check that the abort " &
+ "is deferred until after the rendezvous completes. (Task to PO)");
+
+ -- To pass this test, the following must be true:
+ --
+ -- (A) The abort of Print_Request is deferred until after the
+ -- Done_Printing entry body completes.
+ -- (B) Print_Request aborts after the Done_Printing entry call
+ -- completes.
+ --
+ -- Call the entry Verify_Results. The entry call will not be accepted
+ -- until after Print_Request has been requeued to Done_Printing.
+
+ Printer_Server.Verify_Results; -- Accepted after Print_Request is
+ -- requeued to Done_Printing.
+
+ -- Simulate an application which needs access to the printer within
+ -- a specified time, and which aborts the current printer job if time
+ -- runs out.
+
+ select
+ Printer(1).Done_Printing; -- Wait for printer to come free.
+ or
+ delay Long_Enough; -- Print job took too long.
+ abort Print_Request; -- Abort print job.
+ end select;
+
+ Printer_Server.Verify_Results; -- Abortion completion point: force
+ -- abort to complete (if it's going
+ -- to).
+
+ -- Verify that the Done_Printing entry body has not yet completed,
+ -- and thus that Print_Request has not been aborted.
+
+ if Printer(1).Is_Done then
+ Report.Failed ("Target entry of requeue executed prematurely");
+ elsif Print_Request'Terminated then
+ Report.Failed ("Caller was aborted before entry was complete");
+ else
+
+ Printer(1).Handle_Interrupt; -- Simulate a printer interrupt,
+ -- signaling that printing is
+ -- done.
+
+ -- The Done_Printing entry body will complete before the next protected
+ -- action is called (Printer(1).Is_Done). Verify (A) and (B): that the
+ -- Print_Request is aborted.
+
+ Printer_Server.Verify_Results; -- Abortion completion point: force
+ -- Print_Request abort to complete.
+
+ if not Printer(1).Is_Done then
+ Report.Failed ("Target entry of requeue did not complete");
+ end if;
+
+ if not Print_Request'Terminated then
+ Report.Failed ("Task not aborted following completion of entry call");
+ abort Print_Request; -- Try to kill hung task.
+ end if;
+
+ end if;
+
+ Report.Result;
+
+end C954A01;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a02.a b/gcc/testsuite/ada/acats/tests/c9/c954a02.a
new file mode 100644
index 000000000..7d61aea8c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954a02.a
@@ -0,0 +1,259 @@
+-- C954A02.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if a task requeued with abort on a protected entry queue
+-- is aborted, the protected entry call is canceled and the aborted
+-- task becomes completed.
+--
+-- TEST DESCRIPTION:
+-- Declare a protected type which simulates a printer device driver
+-- (foundation code).
+--
+-- Declare a task which simulates a printer server for multiple printers.
+--
+-- For the protected type, declare an entry with a barrier that is set
+-- false by a protected procedure (which simulates starting a print job
+-- on the printer), and is set true by a second protected procedure (which
+-- simulates a handler called when the printer interrupts, indicating
+-- that printing is done).
+--
+-- For the task, declare an entry whose corresponding accept statement
+-- contains a call to first protected procedure of the protected type
+-- (which sets the barrier of the protected entry to false), followed by
+-- a requeue with abort to the protected entry. Declare a second entry
+-- which does nothing.
+--
+-- Declare a "requesting" task which calls the printer server task entry
+-- (and thus executes the requeue). Attempt to abort the requesting
+-- task. Verify that it is aborted, that the requeued entry call is
+-- canceled, and that the corresponding entry body is not executed.
+--
+-- TEST FILES:
+-- This test depends on the following foundation code:
+--
+-- F954A00.A
+--
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 10 Oct 96 SAIC Added pragma elaborate
+--
+--!
+
+package C954A02_0 is -- Printer server abstraction.
+
+ -- Simulate a system with multiple printers. The entry Print requests
+ -- that data be printed on the next available printer. The entry call
+ -- is accepted when a printer is available, and completes when printing
+ -- is done.
+
+
+ task Printer_Server is
+ entry Print (File_Name : String); -- Test the requeue statement.
+ entry Verify_Results; -- Artifice for test purposes.
+ end Printer_Server;
+
+end C954A02_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with F954A00; -- Printer device abstraction.
+use F954A00;
+pragma Elaborate(F954a00);
+
+package body C954A02_0 is -- Printer server abstraction.
+
+ task body Printer_Server is
+ Printers_Busy : Boolean := True;
+ Index : Printer_ID := 1;
+ Print_Accepted : Boolean := False;
+ begin
+
+ loop
+ -- Wait for a printer to become available:
+
+ while Printers_Busy loop
+ Printers_Busy := False; -- Exit loop if
+ -- entry accepted.
+ select
+ Printer(Index).Done_Printing; -- Accepted immed.
+ -- when printer is
+ -- available.
+ else
+ Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed.
+ Printers_Busy := True; -- accepted; keep
+ end select; -- looping.
+
+ -- Allow other task to get control
+ delay ImpDef.Minimum_Task_Switch;
+
+ end loop; -- Value of Index
+ -- at loop exit
+ -- identifies the
+ -- avail. printer.
+
+ -- Wait for a print request or terminate:
+
+ select
+ accept Print (File_Name : String) do
+ Print_Accepted := True; -- Allow
+ -- Verify_Results
+ -- to be accepted.
+
+ Printer(Index).Start_Printing (File_Name); -- Begin printing on
+ -- the available
+ -- -- -- printer.
+ -- Requeue is tested here --
+ -- --
+ -- Requeue caller so
+ requeue Printer(Index).Done_Printing -- server task free
+ with abort; -- to accept other
+ end Print; -- requests.
+ or
+ -- Guard ensures that Verify_Results cannot be accepted
+ -- until after Print has been accepted. This avoids a
+ -- race condition in the main program.
+
+ when Print_Accepted => accept Verify_Results; -- Artifice for
+ -- testing purposes.
+ or
+ terminate;
+ end select;
+
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Exception raised in Printer_Server task");
+ end Printer_Server;
+
+
+end C954A02_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with F954A00; -- Printer device abstraction.
+with C954A02_0; -- Printer server abstraction.
+
+use C954A02_0;
+use F954A00;
+
+procedure C954A02 is
+
+ -- Length of time which simulates a very long process
+ Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue;
+
+ --==============================================--
+
+ task Print_Request; -- Send a print request.
+
+ task body Print_Request is
+ My_File : constant String := "MYFILE.DAT";
+ begin
+ Printer_Server.Print (My_File); -- Invoke requeue statement.
+ Report.Failed ("Task continued execution following entry call");
+ exception
+ when others =>
+ Report.Failed ("Exception raised in Print_Request task");
+ end Print_Request;
+
+ --==============================================--
+
+begin -- Main program.
+
+ Report.Test ("C954A02", "Abort a requeue on a Protected entry");
+
+ -- To pass this test, the following must be true:
+ --
+ -- (A) The abort of Print_Request takes place immediately.
+ -- (B) The Done_Printing entry call is canceled, and the corresponding
+ -- entry body is not executed.
+ --
+ -- Call the entry Verify_Results. The entry call will not be accepted
+ -- until after Print_Request has been requeued to Done_Printing.
+
+ Printer_Server.Verify_Results; -- Accepted after Print_Request is
+ -- requeued to Done_Printing.
+
+ -- Verify that the Done_Printing entry call has not been completed.
+ --
+ if Printer(1).Is_Done then
+ Report.Failed ("Target entry of requeue executed prematurely");
+ else
+
+ -- Simulate an application which needs access to the printer within
+ -- a specified time, and which aborts the current printer job if time
+ -- runs out.
+
+ select
+ Printer(1).Done_Printing; -- Wait for printer to come free.
+ or
+ delay Long_Enough; -- Print job took too long.
+ abort Print_Request; -- Abort print job.
+ end select;
+
+ Printer_Server.Verify_Results; -- Abortion completion point: force
+ -- Print_Request abort to complete.
+
+ -- Verify (A): that Print_Request has been aborted.
+ -- Note: the test will hang if the task as not been aborted
+ --
+ while not Print_Request'Terminated loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- Verify (B): that the Done_Printing entry call was canceled, and
+ -- the corresponding entry body was not executed.
+ --
+ -- Set the barrier of the entry to true, then check that the entry
+ -- body is not executed. If the entry call is NOT canceled, the
+ -- entry body will execute when the barrier is set true.
+
+ Printer(1).Handle_Interrupt; -- Simulate a printer interrupt,
+ -- signaling that printing is
+ -- done.
+ if Printer(1).Is_Done then
+ Report.Failed ("Entry call was not canceled");
+ end if;
+
+
+ end if;
+
+
+ Report.Result;
+
+end C954A02;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a03.a b/gcc/testsuite/ada/acats/tests/c9/c954a03.a
new file mode 100644
index 000000000..13d21311c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c954a03.a
@@ -0,0 +1,322 @@
+-- C954A03.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that a requeue statement in an accept_statement with
+-- parameters may requeue the entry call to a protected entry with no
+-- parameters. Check that, if the call is queued on the new entry's
+-- queue, the original caller remains blocked after the requeue, but
+-- the accept_statement containing the requeue is completed.
+--
+-- Note that this test uses a requeue "with abort," although it does not
+-- check that such a requeued caller can be aborted; that feature is
+-- tested elsewhere.
+--
+-- TEST DESCRIPTION:
+-- Declare a protected type which simulates a printer device driver
+-- (foundation code).
+--
+-- Declare a task which simulates a printer server for multiple printers.
+--
+-- For the protected type, declare an entry with a barrier that is set
+-- false by a protected procedure (which simulates starting a print job
+-- on the printer), and is set true by a second protected procedure (which
+-- simulates a handler called when the printer interrupts, indicating
+-- that printing is done).
+--
+-- For the task, declare an entry whose corresponding accept statement
+-- contains a call to first protected procedure of the protected type
+-- (which sets the barrier of the protected entry to false), followed by
+-- a requeue with abort to the protected entry. Declare a second entry
+-- which does nothing.
+--
+-- Declare a "requesting" task which calls the printer server task entry
+-- (and thus executes the requeue). Verify that, following the requeue,
+-- the requesting task remains blocked. Call the second entry of the
+-- printer server task (the acceptance of this entry call verifies that
+-- the requeue statement completed the entry call by the requesting task.
+-- Call the second protected procedure of the protected type (the
+-- interrupt handler) and verify that the protected entry completes for
+-- the requesting task (which verifies that the requeue statement queued
+-- the first task object to the protected entry).
+--
+-- TEST FILES:
+-- This test depends on the following foundation code:
+--
+-- F954A00.A
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 10 Oct 96 SAIC Added pragma elaborate.
+--
+--!
+
+package C954A03_0 is -- Printer server abstraction.
+
+ -- Simulate a system with multiple printers. The entry Print requests
+ -- that data be printed on the next available printer. The entry call
+ -- is accepted when a printer is available, and completes when printing
+ -- is done.
+
+ task Printer_Server is
+ entry Print (File_Name : String); -- Test the requeue statement.
+ entry Verify_Results; -- Artifice for test purposes.
+ end Printer_Server;
+
+end C954A03_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with F954A00; -- Printer device abstraction.
+use F954A00;
+pragma Elaborate(F954a00);
+
+package body C954A03_0 is -- Printer server abstraction.
+
+
+ task body Printer_Server is
+ Printers_Busy : Boolean := True;
+ Index : Printer_ID := 1;
+ Print_Accepted : Boolean := False;
+ begin
+
+ loop
+ -- Wait for a printer to become available:
+
+ while Printers_Busy loop
+ Printers_Busy := False; -- Exit loop if
+ -- entry accepted.
+ select
+ Printer(Index).Done_Printing; -- Accepted immed.
+ -- when printer is
+ -- available.
+ else
+ Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed.
+ Printers_Busy := True; -- accepted; keep
+ end select; -- looping.
+
+ -- Allow other tasks to get control
+ delay ImpDef.Minimum_Task_Switch;
+
+ end loop;
+ -- Value of Index
+ -- at loop exit
+ -- identifies the
+ -- avail. printer.
+
+ -- Wait for a print request or terminate:
+
+ select
+ accept Print (File_Name : String) do
+ Print_Accepted := True; -- Allow
+ -- Verify_Results
+ -- to be accepted.
+
+ Printer(Index).Start_Printing (File_Name); -- Begin printing on
+ -- the available
+ -- -- -- printer.
+ -- Requeue is tested here --
+ -- --
+ -- Requeue caller so
+ requeue Printer(Index).Done_Printing -- server task free
+ with abort; -- to accept other
+ end Print; -- requests.
+ or
+ -- Guard ensures that Verify_Results cannot be accepted
+ -- until after Print has been accepted. This avoids a
+ -- race condition in the main program.
+
+ when Print_Accepted => accept Verify_Results; -- Artifice for
+ -- testing purposes.
+ or
+ terminate;
+ end select;
+
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Exception raised in Printer_Server task");
+ end Printer_Server;
+
+
+end C954A03_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with F954A00; -- Printer device abstraction.
+with C954A03_0; -- Printer server abstraction.
+
+use C954A03_0;
+use F954A00;
+
+procedure C954A03 is
+
+ Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue;
+
+
+ --==============================================--
+
+ Task_Completed : Boolean := False; -- Testing flag.
+
+ protected Interlock is -- Artifice for test purposes.
+ entry Wait; -- Wait for lock to be released.
+ procedure Release; -- Release the lock.
+ private
+ Locked : Boolean := True;
+ end Interlock;
+
+
+ protected body Interlock is
+
+ entry Wait when not Locked is -- Calls are queued until after
+ -- -- Release is called.
+ begin
+ Task_Completed := True;
+ end Wait;
+
+ procedure Release is -- Called by Print_Request.
+ begin
+ Locked := False;
+ end Release;
+
+ end Interlock;
+
+ --==============================================--
+
+ task Print_Request is -- Send a print request.
+ end Print_Request;
+
+ task body Print_Request is
+ My_File : constant String := "MYFILE.DAT";
+ begin
+ Printer_Server.Print (My_File); -- Invoke requeue statement.
+ Interlock.Release; -- Allow main to continue.
+ exception
+ when others =>
+ Report.Failed ("Exception raised in Print_Request task");
+ end Print_Request;
+
+ --==============================================--
+
+begin -- Main program.
+
+ Report.Test ("C954A03", "Requeue from an Accept with parameters" &
+ " to a Protected Entry without parameters");
+
+ -- To pass this test, the following must be true:
+ --
+ -- (A) The Print entry call made by the task Print_Request must be
+ -- completed by the requeue statement.
+ -- (B) Print_Request must remain blocked following the requeue.
+ -- (C) Print_Request must be queued on the Done_Printing queue of
+ -- Printer(1).
+ -- (D) Print_Request must continue execution after Done_Printing is
+ -- complete.
+ --
+ -- First, verify (A): that the Print entry call is complete.
+ --
+ -- Call the entry Verify_Results. If the requeue statement completed the
+ -- entry call to Print, the entry call to Verify_Results should be
+ -- accepted. Since the main will hang if this is NOT the case, make this
+ -- a timed entry call.
+
+ select
+ Printer_Server.Verify_Results; -- Accepted if requeue completed
+ -- entry call to Print.
+ or
+ delay Long_Enough; -- Time out otherwise.
+ Report.Failed ("Requeue did not complete entry call");
+ end select;
+
+ -- Now verify (B): that Print_Request remains blocked following the
+ -- requeue. Also verify that Done_Printing (the entry to which
+ -- Print_Request should have been queued) has not yet executed.
+
+ if Printer(1).Is_Done then
+ Report.Failed ("Target entry of requeue executed prematurely");
+ elsif Print_Request'Terminated then
+ Report.Failed ("Caller did not remain blocked after the requeue");
+ else
+
+ -- Verify (C): that Print_Request is queued on the
+ -- Done_Printing queue of Printer(1).
+ --
+ -- Set the barrier for Printer(1).Done_Printing to true. Check
+ -- that the Done flag is updated and that Print_Request terminates.
+
+ Printer(1).Handle_Interrupt; -- Simulate a printer interrupt,
+ -- signaling that printing is
+ -- done.
+
+ -- The Done_Printing entry body will complete before the next
+ -- protected action is called (Printer(1).Is_Done).
+
+ if not Printer(1).Is_Done then
+ Report.Failed ("Caller was not requeued on target entry");
+ end if;
+
+ -- Finally, verify (D): that Print_Request continues after Done_Printing
+ -- completes.
+ --
+ -- After Done_Printing completes, there is a potential race condition
+ -- between the main program and Print_Request. The protected object
+ -- Interlock is provided to ensure that the check of whether
+ -- Print_Request continued is made *after* it has had a chance to do so.
+ -- The main program waits until the statement in Print_Request following
+ -- the requeue-causing statement has executed, then checks to see
+ -- whether Print_Request did in fact continue executing.
+ --
+ -- Note that the test will hang here if Print_Request does not continue
+ -- executing following the completion of the requeued entry call.
+
+ Interlock.Wait; -- Wait until Print_Request is
+ -- done.
+ if not Task_Completed then
+ Report.Failed ("Caller remained blocked after target " &
+ "entry released");
+ end if;
+
+ -- Wait for Print_Request to finish before calling Report.Result.
+ while not Print_Request'Terminated loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ end if;
+
+ Report.Result;
+
+end C954A03;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c960001.a b/gcc/testsuite/ada/acats/tests/c9/c960001.a
new file mode 100644
index 000000000..4eaa1f49f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c960001.a
@@ -0,0 +1,164 @@
+-- C960001.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Confirm that a simple Delay Until statement is performed. Check
+-- that the delay does not complete before the requested time and that it
+-- does complete thereafter
+--
+-- TEST DESCRIPTION:
+-- Simulate a task that sends a "pulse" at regular intervals. The Delay
+-- Until statement is used to avoid accumulated drift. For the
+-- test, we expect the delay to return very close to the requested time;
+-- we use an additional Pulse_Time_Delta for the limit. The test
+-- driver (main) artificially limits the number of iterations by setting
+-- the Stop_Pulse Boolean after a small number.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 15 Nov 95 SAIC Fixed global variable problem for ACVC 2.0.1
+--
+--!
+
+with Report;
+with Ada.Calendar;
+with ImpDef;
+
+procedure C960001 is
+
+begin
+
+ Report.Test ("C960001", "Simple Delay Until");
+
+ declare -- To get the Report.Result after all has completed
+
+ function "+" (Left : Ada.Calendar.Time; Right: Duration)
+ return Ada.Calendar.Time renames Ada.Calendar."+";
+ function "<" (Left, Right : Ada.Calendar.Time)
+ return Boolean renames Ada.Calendar."<";
+ function ">" (Left, Right : Ada.Calendar.Time)
+ return Boolean renames Ada.Calendar.">";
+
+ TC_Loop_Count : integer range 0..4 := 0;
+
+
+ -- control over stopping tasks
+ protected Control is
+ procedure Stop_Now;
+ function Stop return Boolean;
+ private
+ Halt : Boolean := False;
+ end Control;
+
+ protected body Control is
+ procedure Stop_Now is
+ begin
+ Halt := True;
+ end Stop_Now;
+
+ function Stop return Boolean is
+ begin
+ return Halt;
+ end Stop;
+ end Control;
+
+ task Pulse_Task is
+ entry Trigger;
+ end Pulse_Task;
+
+
+ -- Task to synchronize all qualified receivers.
+ -- The entry Trigger starts the synchronization; Control.Stop
+ -- becoming true terminates the task.
+ --
+ task body Pulse_Task is
+
+ Pulse_Time : Ada.Calendar.Time;
+
+ Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue;
+
+ TC_Last_Time : Ada.Calendar.Time;
+ TC_Current : Ada.Calendar.Time;
+
+
+ -- This routine transmits a synchronizing "pulse" to
+ -- all receivers
+ procedure Pulse is
+ begin
+ null; -- Stub
+ Report.Comment (".......PULSE........");
+ end Pulse;
+
+ begin
+ accept Trigger;
+
+ Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta;
+ TC_Last_Time := Pulse_Time;
+
+ while not Control.Stop loop
+ delay until Pulse_Time;
+ Pulse;
+
+ -- Calculate time for next pulse. Note: this is based on the
+ -- last pulse time, not the time we returned from the delay
+ --
+ Pulse_Time := Pulse_Time + Pulse_Time_Delta;
+
+ -- Test Control:
+ TC_Current := Ada.Calendar.Clock;
+ if TC_Current < TC_Last_Time then
+ Report.Failed ("Delay expired before requested time");
+ end if;
+ if TC_Current > Pulse_Time then
+ Report.Failed ("Delay too long");
+ end if;
+ TC_Last_Time := Pulse_Time;
+ TC_Loop_Count := TC_Loop_Count +1;
+ end loop;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Pulse_Task");
+ end Pulse_Task;
+
+
+
+ begin -- declare
+
+ Pulse_Task.Trigger; -- Start test
+
+ -- Artificially limit the number of iterations
+ while TC_Loop_Count < 3 loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+ --
+ Control.Stop_Now; -- End test
+
+ end; -- declare
+
+ Report.Result;
+
+end C960001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c960002.a b/gcc/testsuite/ada/acats/tests/c9/c960002.a
new file mode 100644
index 000000000..06edaf0c9
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c960002.a
@@ -0,0 +1,171 @@
+-- C960002.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the simple "delay until" when the request time is "now" and
+-- also some time already in the past is obeyed and returns immediately
+--
+-- TEST DESCRIPTION:
+-- Simulate a task that sends a "pulse" at regular intervals. The Delay
+-- Until statement is used to avoid accumulated drift. In this test
+-- three simple situations simulating the start of drift are used: the
+-- next pulse being called for at the normal time, the next pulse being
+-- called for at exactly the current time and then at some time which has
+-- already past. We assume the delay is within a While Loop and, to
+-- simplify the test, we "unfold" the While Loop and execute the Delays
+-- in a serial fashion. This loop is shown in test C960001.
+-- It is not possible to test the actual immediacy of the expiration. We
+-- can only check that it returns in a "reasonable" time. In this case
+-- we check that it expires before the next "pulse" should have been
+-- issued.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+with ImpDef;
+
+with Ada.Calendar;
+with System;
+
+procedure C960002 is
+
+begin
+
+ Report.Test ("C960002", "Simple Delay Until with requested time being" &
+ " ""now"" and time already in the past");
+
+ declare -- To get the Report.Result after all has completed
+
+ function "+" (Left : Ada.Calendar.Time; Right: Duration)
+ return Ada.Calendar.Time renames Ada.Calendar."+";
+ function "-" (Left : Ada.Calendar.Time; Right: Duration)
+ return Ada.Calendar.Time renames Ada.Calendar."-";
+ function "-" (Left, Right : Ada.Calendar.Time)
+ return duration renames Ada.Calendar."-";
+ function ">" (Left, Right : Ada.Calendar.Time)
+ return Boolean renames Ada.Calendar.">";
+
+
+ task Pulse_Task is
+ entry Trigger;
+ end Pulse_Task;
+
+
+ -- Task to synchronize all qualified receivers.
+ -- The entry Trigger starts the synchronization.
+ --
+ task body Pulse_Task is
+ Pulse_Time : Ada.Calendar.Time;
+ Pulse_Time_Delta : constant duration := ImpDef.Clear_Ready_Queue;
+
+
+
+ TC_Time_Back : Ada.Calendar.Time;
+
+
+ -- This routine transmits a synchronizing "pulse" to
+ -- all receivers
+ procedure Pulse is
+ begin
+ null; -- Stub
+ Report.Comment (".......PULSE........");
+ end Pulse;
+
+ begin
+ accept Trigger;
+ Pulse;
+ ---------------
+ -- normal calculation for "next"
+ Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta;
+
+ -- TC: unfold the "while" loop in C960001. Four passes through
+ -- the loop are shown
+
+ delay until Pulse_Time;
+
+ Pulse;
+ ---------------
+ -- TC: the normal calculation for "next" would be
+ -- Pulse_Time := Pulse_Time + Pulse_Time_Delta;
+ -- Instead of this normal pulse time calculation simulate
+ -- the new pulse time to be exactly "now" (or, as exactly as
+ -- we can)
+ Pulse_Time := Ada.Calendar.Clock;
+ delay until Ada.Calendar.Clock;
+
+ TC_Time_Back := Ada.Calendar.Clock;
+
+ -- Now check for reasonableness
+ if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then
+ Report.Failed
+ ("""Now"" delayed for more than Pulse_Time_Delta - A");
+ end if;
+ Pulse;
+ ---------------
+ -- normal calculation for "next" would be
+ Pulse_Time := Pulse_Time + Pulse_Time_Delta;
+
+ -- TC: Instead of this, simulate the new calculated pulse time
+ -- being already past
+ Pulse_Time := Ada.Calendar.Clock - System.Tick;
+ delay until Pulse_Time;
+
+ TC_Time_Back := Ada.Calendar.Clock;
+
+ -- Now check for reasonableness
+ if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then
+ Report.Failed
+ ("""Now"" delayed for more than Pulse_Time_Delta - B");
+ end if;
+ Pulse;
+ ---------------
+ -- normal calculation for "next"
+ Pulse_Time := Pulse_Time + Pulse_Time_Delta;
+ -- Now simulate getting back into synch
+ delay until Pulse_Time;
+ Pulse;
+ ---------------
+ -- This would be the end of the "while" loop
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Pulse_Task");
+ end Pulse_Task;
+
+
+
+ begin -- declare
+
+ Pulse_Task.Trigger; -- Start test
+
+ end; -- declare
+
+ Report.Result;
+
+end C960002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c960004.a b/gcc/testsuite/ada/acats/tests/c9/c960004.a
new file mode 100644
index 000000000..f394aab66
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c960004.a
@@ -0,0 +1,206 @@
+-- C960004.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- With the triggering statement being a delay and with the Asynchronous
+-- Select statement being in a tasking situation complete the abortable
+-- part before the delay expires. Check that the delay is cancelled
+-- and that the optional statements in the triggering part are not
+-- executed.
+--
+-- TEST DESCRIPTION:
+-- Simulate the creation of a carrier task to control the output of
+-- a message via a line driver. If the message sending process is
+-- not complete (the completion of the rendezvous) within a
+-- specified time the carrier task is designed to take corrective action.
+-- Use an asynchronous select to control the timing; arrange that
+-- the abortable part (the rendezvous) completes almost immediately.
+-- Check that the optional statements are not executed and that the
+-- test completes well before the time of the trigger delay request thus
+-- showing that it has been cancelled.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+with Ada.Calendar;
+
+procedure C960004 is
+
+ function "-" (Left, Right : Ada.Calendar.Time)
+ return Duration renames Ada.Calendar."-";
+ TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
+ TC_Elapsed_Time : duration;
+
+ -- Note: a properly executing test will complete immediately.
+ Allowable_ACK_Time : duration := 600.0;
+
+begin
+
+ Report.Test ("C960004", "ATC: When abortable part completes before " &
+ "a triggering delay, check that the delay " &
+ "is cancelled & optional statements " &
+ "are not performed. Tasking situation");
+
+ declare -- To get the Report.Result after all has completed
+
+ type Sequence_Number is range 1..1_999_999; -- Message Number
+ subtype S_length_subtype is integer range 1..80;
+
+ type Message_Type (Max_String : S_length_subtype := 1) is
+ record
+ Message_Number : Sequence_Number;
+ Alpha : string(1..Max_String);
+ end record;
+
+ -- TC: Dummy message for the test
+ Dummy_Alpha : constant string := "This could be printed";
+ Message_to_Send : Message_Type (Max_string => Dummy_Alpha'length);
+
+
+ -- This is the carrier task. One of these is created for each
+ -- message that requires ACK
+ --
+ task type Require_ACK_task is
+ entry Message_In (Message_to_Send: Message_Type);
+ end Require_ACK_task;
+ type acc_Require_ACK_task is access Require_ACK_task;
+
+
+ --:::::::::::::::::::::::::::::::::
+ -- There would also be another task type "No_ACK_Task" which would
+ -- be the carrier task for those messages not requiring an ACK.
+ -- This task would call Send_Message.ACK_Not_Required. It is not
+ -- shown in this test as it is not used.
+ --:::::::::::::::::::::::::::::::::
+
+
+
+ task Send_Message is
+ entry ACK_Required (Message_to_Send: Message_Type);
+ entry ACK_Not_Required (Message_to_Send: Message_Type);
+ end Send_Message;
+
+
+ -- This is the carrier task. One of these is created for each
+ -- message that requires ACK
+ --
+ task body Require_ACK_task is
+ Hold_Message : Message_Type;
+
+ procedure Time_Out (Failed_Message_Number : Sequence_Number) is
+ begin
+ -- Take remedial action on the timed-out message
+ null; -- stub
+
+ Report.Failed ("Optional statements in triggering part" &
+ " were performed");
+ end Time_out;
+
+ begin
+ accept Message_In (Message_to_Send: Message_Type) do
+ Hold_Message := Message_to_Send; -- to release caller
+ end Message_In;
+
+ -- Now put the message out to the Send_Message task and
+ -- wait (no more than Allowable_Ack_Time) for its completion
+ --
+ select
+ delay Allowable_ACK_Time;
+ -- ACK not received in specified time
+ Time_out (Hold_Message.Message_Number);
+ then abort
+ -- If the rendezvous is not completed in the above time, this
+ -- call is cancelled
+ -- Note: for this test this call will complete immediately
+ -- and thus the trigger should be cancelled
+ Send_Message.ACK_Required (Hold_Message);
+ end select;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Require_ACK_task");
+ end Require_ACK_task;
+
+
+ -- This is the Line Driver task
+ --
+ task body Send_Message is
+ Hold_Non_ACK_Message : Message_Type;
+ begin
+ loop
+ select
+ accept ACK_Required (Message_to_Send: Message_Type) do
+ -- Here send the message from within the rendezvous
+ -- waiting for full transmission to complete
+ null; -- stub
+ -- Note: In this test this accept will complete immediately
+ end ACK_Required;
+ or
+ accept ACK_Not_Required (Message_to_Send: Message_Type) do
+ Hold_Non_ACK_Message := Message_to_Send;
+ end ACK_Not_Required;
+ -- Here send the message from outside the rendezvous
+ null; -- stub
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others => Report.Failed ("Unexpected exception in Send_Message");
+ end Send_Message;
+
+ begin -- declare
+ -- Build a dummy message
+ Message_to_Send.Alpha := Dummy_Alpha;
+ Message_to_Send.Message_Number := 110_693;
+
+ declare
+ New_Require_ACK_task : acc_Require_ACK_task :=
+ new Require_ACK_task;
+ begin
+ -- Create a carrier task for this message and pass the latter in
+ New_Require_ACK_task.Message_In (Message_to_Send);
+ end; -- declare
+
+ end; -- declare
+
+ --Once we are out of the above declarative region, all tasks have completed
+
+ TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time;
+
+ -- Check that the test has completed well before the time of the requested
+ -- delay to ensure the delay was cancelled
+ --
+ if (TC_Elapsed_Time > Allowable_ACK_Time/2) then
+ Report.Failed ("Triggering delay statement was not cancelled");
+ end if;
+
+ Report.Result;
+end C960004;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96001a.ada b/gcc/testsuite/ada/acats/tests/c9/c96001a.ada
new file mode 100644
index 000000000..f958ea107
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96001a.ada
@@ -0,0 +1,163 @@
+-- C96001A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT A DELAY STATEMENT DELAYS EXECUTION FOR AT LEAST THE
+-- SPECIFIED TIME. SPECIFICALLY,
+-- (A) POSITIVE DELAY ARGUMENT.
+-- (B) NEGATIVE DELAY ARGUMENT.
+-- (C) ZERO DELAY ARGUMENT.
+-- (D) DURATION'SMALL DELAY ARGUMENT.
+-- (E) EXPRESSION OF TYPE DURATION AS DELAY ARGUMENT.
+
+-- HISTORY:
+-- CPP 8/14/84 CREATED ORIGINAL TEST.
+-- RJW 11/13/87 ADDED CODE WHICH ALLOWS TEST TO REPORT "PASSED"
+-- IF TICK > DURATION'SMALL.
+
+with Impdef;
+WITH CALENDAR; USE CALENDAR;
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C96001A IS
+
+ SUBTYPE INT IS INTEGER RANGE 0 .. 20_000;
+
+BEGIN
+ TEST ("C96001A", "CHECK THAT DELAY STATEMENT DELAYS " &
+ "EXECUTION FOR AT LEAST THE SPECIFIED TIME");
+
+ ---------------------------------------------
+
+ DECLARE -- (A)
+ X : DURATION := 5.0 * Impdef.One_Second;
+ OLD_TIME : TIME;
+ LAPSE : DURATION;
+ BEGIN -- (A)
+ LOOP
+ OLD_TIME := CLOCK;
+ DELAY X;
+ LAPSE := CLOCK - OLD_TIME;
+ EXIT;
+ END LOOP;
+ IF LAPSE < X THEN
+ FAILED ("DELAY DID NOT LAPSE AT LEAST 5.0 " &
+ "SECONDS - (A)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (A)");
+ END;
+
+ ---------------------------------------------
+
+ DECLARE -- (B)
+ OLD_TIME : TIME;
+ LAPSE : DURATION;
+ BEGIN -- (B)
+ LOOP
+ OLD_TIME := CLOCK;
+ DELAY -5.0;
+ LAPSE := CLOCK - OLD_TIME;
+ EXIT;
+ END LOOP;
+ COMMENT ("(B) - NEGATIVE DELAY LAPSED FOR " &
+ INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (B)");
+ END;
+
+ ---------------------------------------------
+
+ DECLARE -- (C)
+ X : DURATION := 0.0;
+ OLD_TIME : TIME;
+ LAPSE : DURATION;
+ BEGIN -- (C)
+ LOOP
+ OLD_TIME := CLOCK;
+ DELAY X;
+ LAPSE := CLOCK - OLD_TIME;
+ EXIT;
+ END LOOP;
+ COMMENT ("(C) - ZERO DELAY LAPSED FOR " &
+ INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (C)");
+ END;
+
+ ---------------------------------------------
+
+ DECLARE -- (D)
+ X : DURATION := DURATION'SMALL;
+ OLD_TIME : TIME;
+ LAPSE : DURATION;
+ BEGIN -- (D)
+ LOOP
+ OLD_TIME := CLOCK;
+ DELAY X;
+ LAPSE := CLOCK - OLD_TIME;
+ EXIT;
+ END LOOP;
+ IF LAPSE < X THEN
+ IF TICK < DURATION'SMALL THEN
+ FAILED ("DELAY DID NOT LAPSE AT LEAST " &
+ "DURATION'SMALL SECONDS - (D)");
+ ELSE
+ COMMENT ("TICK > DURATION'SMALL SO DELAY IN " &
+ "'(D)' IS NOT MEASURABLE");
+ END IF;
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (D)");
+ END;
+
+ ---------------------------------------------
+
+ DECLARE -- (E)
+ INC1 : DURATION := 2.0 * Impdef.One_Second;
+ INC2 : DURATION := 3.0 * Impdef.One_Second;
+ OLD_TIME : TIME;
+ LAPSE : DURATION;
+ BEGIN -- (E)
+ LOOP
+ OLD_TIME := CLOCK;
+ DELAY INC1 + INC2;
+ LAPSE := CLOCK - OLD_TIME;
+ EXIT;
+ END LOOP;
+ IF LAPSE < (INC1 + INC2) THEN
+ FAILED ("DELAY DID NOT LAPSE AT LEAST " &
+ "INC1 + INC2 SECONDS - (E)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (E)");
+ END;
+
+ RESULT;
+END C96001A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96004a.ada b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada
new file mode 100644
index 000000000..f5357fc51
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada
@@ -0,0 +1,258 @@
+-- C96004A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT THE PRE-DEFINED SUBTYPES FROM THE PACKAGE CALENDAR,
+-- NAMELY YEAR_NUMBER, MONTH_NUMBER, DAY_NUMBER, AND DAY_DURATION,
+-- HAVE THE CORRECT RANGE CONSTRAINTS. SUBTESTS ARE:
+-- (A) YEAR_NUMBER.
+-- (B) MONTH_NUMBER.
+-- (C) DAY_NUMBER.
+-- (D) DAY_DURATION.
+
+-- HISTORY:
+-- CPP 08/15/84 CREATED ORIGINAL TEST.
+-- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
+-- OPTIMIZATION.
+
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+PROCEDURE C96004A IS
+
+BEGIN
+ TEST("C96004A", "CHECK THAT PRE-DEFINED SUBTYPES FROM THE " &
+ "CALENDAR PACKAGE HAVE CORRECT RANGE CONSTRAINTS");
+
+ ---------------------------------------------
+
+ DECLARE -- (A)
+
+ YR : YEAR_NUMBER;
+
+ BEGIN -- (A)
+
+ BEGIN
+ YR := 1900;
+ FAILED ("EXCEPTION NOT RAISED - (A)1");
+ IF NOT EQUAL (YR, YR) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (A)1");
+ END;
+
+ BEGIN
+ YR := 84;
+ FAILED ("EXCEPTION NOT RAISED - (A)2");
+ IF NOT EQUAL (YR, YR) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (A)2");
+ END;
+
+ BEGIN
+ YR := 2099;
+ IF NOT EQUAL (YR, YR) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("OK CASE RAISED EXCEPTION ON 2099 - (A)");
+ END;
+
+ BEGIN
+ YR := IDENT_INT(YEAR_NUMBER'LAST + 1);
+ FAILED ("EXCEPTION NOT RAISED - (A)3");
+ IF NOT EQUAL (YR, YR) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (A)3");
+ END;
+
+ END; -- (A)
+
+ ---------------------------------------------
+
+ DECLARE -- (B)
+
+ MO : MONTH_NUMBER;
+
+ BEGIN -- (B)
+
+ BEGIN
+ MO := IDENT_INT(0);
+ FAILED ("EXCEPTION NOT RAISED - (B)1");
+ IF NOT EQUAL (MO, MO) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)1");
+ END;
+
+ BEGIN
+ MO := 12;
+ IF NOT EQUAL (MO, MO) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("OK CASE RAISED EXCEPTION ON 12 - (B)");
+ END;
+
+ BEGIN
+ MO := 13;
+ FAILED ("EXCEPTION NOT RAISED - (B)2");
+ IF NOT EQUAL (MO, MO) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)2");
+ END;
+
+ END; -- (B)
+
+ ---------------------------------------------
+
+ DECLARE -- (C)
+
+ DY : DAY_NUMBER;
+
+ BEGIN -- (C)
+
+ BEGIN
+ DY := 0;
+ FAILED ("EXCEPTION NOT RAISED - (C)1");
+ IF NOT EQUAL (DY, DY) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (C)1");
+ END;
+
+ BEGIN
+ DY := IDENT_INT(32);
+ FAILED ("EXCEPTION NOT RAISED - (C)2");
+ IF NOT EQUAL (DY, DY) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (C)2");
+ END;
+
+ END; -- (C)
+
+ ---------------------------------------------
+
+ DECLARE -- (D)
+
+ SEGMENT : DAY_DURATION;
+
+ FUNCTION CHECK_OK (X : DAY_DURATION) RETURN BOOLEAN IS
+ I : INTEGER := INTEGER (X);
+ BEGIN
+ RETURN EQUAL (I,I);
+ END CHECK_OK;
+
+ BEGIN -- (D)
+
+ BEGIN
+ SEGMENT := 86_400.0;
+ IF CHECK_OK (SEGMENT - 86_000.0) THEN
+ COMMENT ("NO EXCEPTION RAISED (D1)");
+ ELSE
+ COMMENT ("NO EXCEPTION RAISED (D2)");
+ END IF;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("OK CASE RAISED EXCEPTION ON 86_400 - (D)");
+ END;
+
+ BEGIN
+ SEGMENT := -4.0;
+ FAILED ("EXCEPTION NOT RAISED - (D)1");
+ IF NOT EQUAL (INTEGER(SEGMENT), INTEGER(SEGMENT)) THEN
+ COMMENT ("NO EXCEPTION RAISED (D3)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (D)1");
+ END;
+
+ BEGIN
+ SEGMENT := 86_401.00;
+ IF CHECK_OK (SEGMENT - 86_000.0) THEN
+ FAILED ("NO EXCEPTION RAISED (D4)");
+ ELSE
+ FAILED ("NO EXCEPTION RAISED (D5)");
+ END IF;
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (D)2");
+ END;
+
+ END; -- (D)
+
+ ---------------------------------------------
+
+ RESULT;
+END C96004A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005a.ada b/gcc/testsuite/ada/acats/tests/c9/c96005a.ada
new file mode 100644
index 000000000..ca6fc5b83
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96005a.ada
@@ -0,0 +1,239 @@
+-- C96005A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN
+-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING.
+-- SPECIFICALLY,
+-- (A) CHECK THAT ADDITION AND SUBTRACTION OPERATORS WORK CORRECTLY ON
+-- VALUES OF TYPE TIME.
+
+-- CPP 8/16/84
+
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+-- WITH TEXT_IO; USE TEXT_IO;
+PROCEDURE C96005A IS
+
+ -- PACKAGE DURATION_IO IS NEW FIXED_IO (DURATION);
+ -- USE DURATION_IO;
+
+BEGIN
+ TEST ("C96005A", "CHECK THAT THE ADDITION AND SUBTRACTION " &
+ "FUNCTIONS FOR VALUES OF TYPE TIME WORK CORRECTLY");
+
+ -----------------------------------------------
+
+ BEGIN -- (A)
+
+ -- ADDITION TESTS FOLLOW.
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 0.0);
+ NEW_TIME := NOW + INCREMENT;
+ IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN
+ FAILED ("SUM OF TIMES IS INCORRECT - (A)1");
+ END IF;
+ END;
+
+
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 0.0);
+ NEW_TIME := INCREMENT + NOW;
+ IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN
+ FAILED ("SUM OF TIMES IS INCORRECT - (A)2");
+ END IF;
+ END;
+
+
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 0.0);
+ NEW_TIME := "+"(INCREMENT, NOW);
+ IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN
+ FAILED ("SUM OF TIMES IS INCORRECT - (A)3");
+ END IF;
+ END;
+
+
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 0.0);
+ NEW_TIME := "+"(LEFT => NOW,
+ RIGHT => INCREMENT);
+ IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN
+ FAILED ("SUM OF TIMES IS INCORRECT - (A)4");
+ END IF;
+ END;
+
+
+ -- SUBTRACTION TESTS FOLLOW.
+ DECLARE
+ NOW, ONCE : TIME;
+ DIFFERENCE : DURATION;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 45_000.0);
+ ONCE := TIME_OF (1984, 8, 12, 45_000.0);
+ DIFFERENCE := NOW - ONCE;
+ IF DIFFERENCE /= 86_400.0 THEN
+ FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)1");
+ -- COMMENT ("DIFFERENCE YIELDS: ");
+ -- PUT (DIFFERENCE);
+ END IF;
+ END;
+
+
+ DECLARE
+ -- TIMES IN DIFFERENT MONTHS.
+ NOW, ONCE : TIME;
+ DIFFERENCE : DURATION;
+ BEGIN
+ NOW := TIME_OF (1984, 8, IDENT_INT(1), 60.0);
+ ONCE := TIME_OF (1984, 7, 31, 86_399.0);
+ DIFFERENCE := "-"(NOW, ONCE);
+ IF DIFFERENCE /= 61.0 THEN
+ FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)2");
+ -- COMMENT ("DIFFERENCE YIELDS: ");
+ -- PUT (DIFFERENCE);
+ END IF;
+ END;
+
+
+ DECLARE
+ -- TIMES IN DIFFERENT YEARS.
+ NOW, AFTER : TIME;
+ DIFFERENCE : DURATION;
+ BEGIN
+ NOW := TIME_OF (IDENT_INT(1999), 12, 31, 86_399.0);
+ AFTER := TIME_OF (2000, 1, 1, 1.0);
+ DIFFERENCE := "-"(LEFT => AFTER,
+ RIGHT => NOW);
+ IF DIFFERENCE /= 2.0 THEN
+ FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)3");
+ -- COMMENT ("DIFFERENCE YIELDS: ");
+ -- PUT (DIFFERENCE);
+ END IF;
+ END;
+
+
+ DECLARE
+ -- TIMES IN A LEAP YEAR.
+ NOW, LEAP : TIME;
+ DIFFERENCE : DURATION;
+ BEGIN
+ NOW := TIME_OF (1984, 3, 1);
+ LEAP := TIME_OF (1984, 2, 29, 86_399.0);
+ DIFFERENCE := NOW - LEAP;
+ IF DIFFERENCE /= 1.0 THEN
+ FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)4");
+ -- COMMENT ("DIFFERENCE YIELDS: ");
+ -- PUT (DIFFERENCE);
+ END IF;
+ END;
+
+
+ DECLARE
+ -- TIMES IN A NON-LEAP YEAR.
+ NOW, NON_LEAP : TIME;
+ DIFFERENCE : DURATION;
+ BEGIN
+ NOW := TIME_OF (1983, 3, 1);
+ NON_LEAP := TIME_OF (1983, 2, 28, 86_399.0);
+ DIFFERENCE := NOW - NON_LEAP;
+ IF DIFFERENCE /= 1.0 THEN
+ FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)5");
+ -- COMMENT ("DIFFERENCE YIELDS: ");
+ -- PUT (DIFFERENCE);
+ END IF;
+ END;
+
+
+ -- SUBTRACTION TESTS FOLLOW: TIME - DURATION.
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 0.0);
+ NEW_TIME := NOW - INCREMENT;
+ IF NEW_TIME /= TIME_OF (1984, 8, 12, 86_399.0) THEN
+ FAILED ("DIFFERENCE OF TIME AND DURATION IS " &
+ "INCORRECT - (A)6");
+ END IF;
+ END;
+
+
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 1, 0.0);
+ NEW_TIME := NOW - INCREMENT;
+ IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN
+ FAILED ("DIFFERENCE OF TIME AND DURATION IS " &
+ "INCORRECT - (A)7");
+ END IF;
+ END;
+
+
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 1, 0.0);
+ NEW_TIME := "-"(LEFT => NOW,
+ RIGHT => INCREMENT);
+ IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN
+ FAILED ("DIFFERENCE OF TIME AND DURATION IS " &
+ "INCORRECT - (A)8");
+ END IF;
+ END;
+
+
+ DECLARE
+ NOW, NEW_TIME : TIME;
+ INCREMENT : DURATION := 1.0;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 1, 0.0);
+ NEW_TIME := "-"(NOW, INCREMENT);
+ IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN
+ FAILED ("DIFFERENCE OF TIME AND DURATION IS " &
+ "INCORRECT - (A)7");
+ END IF;
+ END;
+
+
+ END; -- (A)
+
+ -----------------------------------------------
+
+ RESULT;
+END C96005A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005b.tst b/gcc/testsuite/ada/acats/tests/c9/c96005b.tst
new file mode 100644
index 000000000..f4665b136
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96005b.tst
@@ -0,0 +1,135 @@
+-- C96005B.TST
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN
+-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING.
+-- SPECIFICALLY,
+-- (B) ADDITION AND SUBTRACTION OPERATORS RAISE CONSTRAINT_ERROR WHEN
+-- CALLED WITH AN OUT OF RANGE DURATION PARAMETER.
+
+-- CPP 8/16/84
+
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+PROCEDURE C96005B IS
+
+BEGIN
+ TEST ("C96005B", "CHECK THAT ADDITION AND SUBTRACTION " &
+ "OPERATORS RAISE CONSTRAINT_ERROR WHEN CALLED WITH " &
+ "OUT OF RANGE DURATION PARAMETER");
+
+ -----------------------------------------------
+
+ BEGIN -- (B)
+
+ -- ADDITION TESTS FOLLOW.
+ DECLARE
+ BEFORE : TIME := CLOCK;
+ BEGIN
+ IF DURATION'BASE'FIRST < DURATION'FIRST THEN
+ COMMENT("LOW VALUES EXIST - (B)1");
+ BEFORE := BEFORE + ($LESS_THAN_DURATION);
+ FAILED ("EXCEPTION NOT RAISED - (B)1");
+ ELSE
+ NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)1");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TIME_ERROR =>
+ FAILED ("TIME_ERROR RAISED INSTEAD OF " &
+ "CONSTRAINT_ERROR - (B)1");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)1");
+ END;
+
+ DECLARE
+ BEFORE : TIME := CLOCK;
+ BEGIN
+ IF DURATION'LAST < DURATION'BASE'LAST THEN
+ COMMENT("HIGH VALUES EXIST - (B)2");
+ BEFORE := $GREATER_THAN_DURATION + BEFORE;
+ FAILED ("EXCEPTION NOT RAISED - (B)2");
+ ELSE
+ NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)2");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TIME_ERROR =>
+ FAILED ("TIME_ERROR RAISED INSTEAD OF " &
+ "CONSTRAINT_ERROR - (B)2");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)2");
+ END;
+
+
+ -- SUBTRACTION TESTS FOLLOW.
+ DECLARE
+ BEFORE : TIME := CLOCK;
+ BEGIN
+ IF DURATION'BASE'FIRST < DURATION'FIRST THEN
+ COMMENT("LOW VALUES EXIST - (B)3");
+ BEFORE := BEFORE - ($LESS_THAN_DURATION);
+ FAILED ("EXCEPTION NOT RAISED - (B)3");
+ ELSE
+ NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)3");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TIME_ERROR =>
+ FAILED ("TIME_ERROR RAISED INSTEAD OF " &
+ "CONSTRAINT_ERROR - (B)3");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)3");
+ END;
+
+ DECLARE
+ BEFORE : TIME := CLOCK;
+ BEGIN
+ IF DURATION'LAST < DURATION'BASE'LAST THEN
+ COMMENT("HIGH VALUES EXIST - (B)4");
+ BEFORE := BEFORE - $GREATER_THAN_DURATION;
+ FAILED ("EXCEPTION NOT RAISED - (B)4");
+ ELSE
+ NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)4");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN TIME_ERROR =>
+ FAILED ("TIME_ERROR RAISED INSTEAD OF " &
+ "CONSTRAINT_ERROR - (B)4");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)4");
+ END;
+
+
+ END; -- (B)
+
+ -----------------------------------------------
+
+ RESULT;
+END C96005B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005d.ada b/gcc/testsuite/ada/acats/tests/c9/c96005d.ada
new file mode 100644
index 000000000..8caba3e36
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96005d.ada
@@ -0,0 +1,81 @@
+-- C96005D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN
+-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING.
+-- SPECIFICALLY,
+-- (D) THE EXCEPTION TIME_ERROR IS RAISED WHEN THE FUNCTION "-"
+-- RETURNS A VALUE NOT IN THE SUBTYPE RANGE DURATION.
+
+-- CPP 8/16/84
+
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+PROCEDURE C96005D IS
+
+BEGIN
+ TEST ("C96005D", "CHECK THAT THE SUBTRACTION OPERATOR RAISES " &
+ "TIME_ERROR APPROPRIATELY");
+
+ ---------------------------------------------
+
+ BEGIN -- (D)
+
+ DECLARE
+ NOW, LATER : TIME;
+ WAIT : DURATION;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 0.0);
+ LATER := (NOW + DURATION'LAST) + 1.0;
+ WAIT := LATER - NOW;
+ FAILED ("EXCEPTION NOT RAISED - (D)1");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (D)1");
+ END;
+
+
+ DECLARE
+ NOW, LATER : TIME;
+ WAIT : DURATION;
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, 0.0);
+ LATER := (NOW + DURATION'FIRST) - 1.0;
+ WAIT := NOW - LATER;
+ FAILED ("EXCEPTION NOT RAISED - (D)2");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (D)2");
+ END;
+
+ END; -- (D)
+
+ ---------------------------------------------
+
+ RESULT;
+END C96005D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005f.ada b/gcc/testsuite/ada/acats/tests/c9/c96005f.ada
new file mode 100644
index 000000000..89e3d574b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96005f.ada
@@ -0,0 +1,93 @@
+-- C96005F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT PACKAGE CALENDAR + AND - FUNCTIONS WORK PROPERLY,
+-- ESPECIALLY WITH VALUES AT MIDNIGHT.
+
+-- GOM 02/18/85
+-- JWC 05/14/85
+
+WITH REPORT;
+USE REPORT;
+WITH CALENDAR;
+USE CALENDAR;
+
+PROCEDURE C96005F IS
+
+ CURR_DAY1 : CONSTANT TIME := TIME_OF(1984,1,1,0.0);
+ CURR_DAY2 : CONSTANT TIME := TIME_OF(1984,1,1,DAY_DURATION'LAST);
+ CURR_DAY3 : CONSTANT TIME := TIME_OF(1984,1,1,10000.0);
+
+ TOMORROW1 : CONSTANT TIME := TIME_OF(1984,1,2,0.0);
+ TOMORROW2 : CONSTANT TIME := TIME_OF(1984,1,2,DAY_DURATION'LAST);
+ TOMORROW3 : CONSTANT TIME := TIME_OF(1984,1,2,10000.0);
+
+ YESTERDAY1 : CONSTANT TIME := TIME_OF(1983,12,31,0.0);
+ YESTERDAY2 : CONSTANT TIME := TIME_OF(1983,12,31,
+ DAY_DURATION'LAST);
+ YESTERDAY3 : CONSTANT TIME := TIME_OF(1983,12,31,10000.0);
+
+BEGIN
+ TEST("C96005F","CHECKING PACKAGE CALENDAR + AND - FUNCTIONS");
+
+ -- CHECK IF ADDING ONE DAY TO 'CURR_DAY#' TIMES YIELDS
+ -- TIMES EQUAL TO 'TOMORROW'.
+
+ IF (CURR_DAY1 + DAY_DURATION'LAST) /= TOMORROW1 THEN
+ FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY1'");
+ END IF;
+
+ IF (CURR_DAY2 + DAY_DURATION'LAST) /= TOMORROW2 THEN
+ FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY2'");
+ END IF;
+
+ IF (CURR_DAY3 + DAY_DURATION'LAST) /= TOMORROW3 THEN
+ FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY3'");
+ END IF;
+
+ IF (CURR_DAY1 + DAY_DURATION'LAST) /= CURR_DAY2 THEN
+ FAILED("'CURR_DAY1' + 1 /= 'CURR_DAY2'");
+ END IF;
+
+ -- CHECK IF SUBTRACTING ONE DAY FROM 'CURR_DAY#' TIMES YIELDS
+ -- TIMES EQUAL TO 'YESTERDAY'.
+
+ IF (CURR_DAY1 - DAY_DURATION'LAST) /= YESTERDAY1 THEN
+ FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY1'");
+ END IF;
+
+ IF (CURR_DAY2 - DAY_DURATION'LAST) /= YESTERDAY2 THEN
+ FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY2'");
+ END IF;
+
+ IF (CURR_DAY3 - DAY_DURATION'LAST) /= YESTERDAY3 THEN
+ FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY3'");
+ END IF;
+
+ IF (CURR_DAY2 - DAY_DURATION'LAST) /= CURR_DAY1 THEN
+ FAILED("'CURR_DAY2' - 1 /= 'CURR_DAY1'");
+ END IF;
+
+ RESULT;
+END C96005F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96006a.ada b/gcc/testsuite/ada/acats/tests/c9/c96006a.ada
new file mode 100644
index 000000000..0f6448bd2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96006a.ada
@@ -0,0 +1,298 @@
+-- C96006A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT FOR THE PACKAGE CALENDAR, THE RELATIONAL OPERATORS WORK
+-- CORRECTLY FOR OPERANDS OF TYPE TIME AND TYPE DURATION. PARTICULARLY,
+-- (A) RELATIONS BASED ON YEARS.
+-- (B) RELATIONS BASED ON MONTH.
+-- (C) RELATIONS BASED ON SECONDS.
+-- (D) RELATIONS AT EXTREMES OF THE PERMITTED RANGE OF TIME.
+
+-- CPP 8/16/84
+
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+PROCEDURE C96006A IS
+
+BEGIN
+ TEST ("C96006A", "CHECK THAT RELATIONAL OPERATORS WORK " &
+ "CORRECTLY IN THE PACKAGE CALENDAR");
+
+ --------------------------------------------
+
+ DECLARE -- (A)
+ -- RELATIONS BASED ON YEARS.
+ NOW, LATER : TIME;
+ BEGIN -- (A)
+ NOW := TIME_OF (1984, 8, 12, 500.0);
+ LATER := TIME_OF (1985, 8, 12, 500.0);
+
+ IF NOW < LATER THEN
+ COMMENT ("< OPERATOR OK - (A)");
+ ELSE
+ FAILED ("< OPERATOR INCORRECT - (A)");
+ END IF;
+
+ IF NOW <= LATER THEN
+ COMMENT ("<= OPERATOR OK - (A)");
+ ELSE
+ FAILED ("<= OPERATOR INCORRECT - (A)");
+ END IF;
+
+ IF NOW <= NOW THEN
+ COMMENT ("<= OPERATOR OK - (A)2");
+ ELSE
+ FAILED ("<= OPERATOR INCORRECT - (A)2");
+ END IF;
+
+ IF LATER > NOW THEN
+ COMMENT ("> OPERATOR OK - (A)");
+ ELSE
+ FAILED ("> OPERATOR INCORRECT - (A)");
+ END IF;
+
+ IF LATER >= NOW THEN
+ COMMENT (">= OPERATOR OK - (A)");
+ ELSE
+ FAILED (">= OPERATOR INCORRECT - (A)");
+ END IF;
+
+ IF LATER >= LATER THEN
+ COMMENT (">= OPERATOR OK - (A)2");
+ ELSE
+ FAILED (">= OPERATOR INCORRECT - (A)2");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------
+
+ DECLARE -- (B)
+ -- RELATIONS BASED ON MONTH.
+ NOW, LATER : TIME;
+ BEGIN -- (B)
+ NOW := TIME_OF (1984, 8, 12, 500.0);
+ LATER := TIME_OF (1984, 9, 12, 500.0);
+
+ IF NOW < LATER THEN
+ COMMENT ("< OPERATOR OK - (B)");
+ ELSE
+ FAILED ("< OPERATOR INCORRECT - (B)");
+ END IF;
+
+ IF NOW <= LATER THEN
+ COMMENT ("<= OPERATOR OK - (B)");
+ ELSE
+ FAILED ("<= OPERATOR INCORRECT - (B)");
+ END IF;
+
+ IF NOW <= NOW THEN
+ COMMENT ("<= OPERATOR OK - (B)2");
+ ELSE
+ FAILED ("<= OPERATOR INCORRECT - (B)2");
+ END IF;
+
+ IF LATER > NOW THEN
+ COMMENT ("> OPERATOR OK - (B)");
+ ELSE
+ FAILED ("> OPERATOR INCORRECT - (B)");
+ END IF;
+
+ IF LATER >= NOW THEN
+ COMMENT (">= OPERATOR OK - (B)");
+ ELSE
+ FAILED (">= OPERATOR INCORRECT - (B)");
+ END IF;
+
+ IF LATER >= LATER THEN
+ COMMENT (">= OPERATOR OK - (B)2");
+ ELSE
+ FAILED (">= OPERATOR INCORRECT - (B)2");
+ END IF;
+
+ IF NOW = NOW THEN
+ COMMENT ("= OPERATOR OK - (B)");
+ ELSE
+ FAILED ("= OPERATOR INCORRECT - (B)");
+ END IF;
+
+ IF LATER /= NOW THEN
+ COMMENT ("/= OPERATOR OK - (B)");
+ ELSE
+ FAILED ("/= OPERATOR INCORRECT - (B)");
+ END IF;
+
+ END; -- (B)
+
+ --------------------------------------------
+
+ DECLARE -- (C)
+ -- RELATIONS BASED ON SECONDS.
+ NOW, LATER : TIME;
+ INCREMENT : DURATION := 99.9;
+ BEGIN -- (C)
+ NOW := TIME_OF (1984, 8, 12, 500.0);
+ LATER := NOW + INCREMENT;
+
+ IF NOW < LATER THEN
+ COMMENT ("< OPERATOR OK - (C)");
+ ELSE
+ FAILED ("< OPERATOR INCORRECT - (C)");
+ END IF;
+
+ IF NOW <= LATER THEN
+ COMMENT ("<= OPERATOR OK - (C)");
+ ELSE
+ FAILED ("<= OPERATOR INCORRECT - (C)");
+ END IF;
+
+ IF NOW <= NOW THEN
+ COMMENT ("<= OPERATOR OK - (C)2");
+ ELSE
+ FAILED ("<= OPERATOR INCORRECT - (C)2");
+ END IF;
+
+ IF LATER > NOW THEN
+ COMMENT ("> OPERATOR OK - (C)");
+ ELSE
+ FAILED ("> OPERATOR INCORRECT - (C)");
+ END IF;
+
+ IF LATER >= NOW THEN
+ COMMENT (">= OPERATOR OK - (C)");
+ ELSE
+ FAILED (">= OPERATOR INCORRECT - (C)");
+ END IF;
+
+ IF LATER >= LATER THEN
+ COMMENT (">= OPERATOR OK - (C)2");
+ ELSE
+ FAILED (">= OPERATOR INCORRECT - (C)2");
+ END IF;
+
+ IF LATER = LATER THEN
+ COMMENT ("= OPERATOR OK - (C)");
+ ELSE
+ FAILED ("= OPERATOR INCORRECT - (C)");
+ END IF;
+
+ IF NOW /= LATER THEN
+ COMMENT ("/= OPERATOR OK - (C)");
+ ELSE
+ FAILED ("/= OPERATOR INCORRECT - (C)");
+ END IF;
+
+ IF NOW < NOW THEN
+ FAILED ("NOW < NOW INCORRECT - (C)");
+ ELSIF NOW /= NOW THEN
+ FAILED ("NOW = NOW INCORRECT - (C)");
+ ELSIF LATER < NOW THEN
+ FAILED ("LATER < NOW INCORRECT - (C)");
+ ELSIF LATER <= NOW THEN
+ FAILED ("LATER <= NOW INCORRECT - (C)");
+ ELSIF LATER = NOW THEN
+ FAILED ("NOW = LATER INCORRECT - (C)");
+ ELSIF NOW > LATER THEN
+ FAILED ("NOW > LATER INCORRECT - (C)");
+ ELSIF NOW > NOW THEN
+ FAILED ("NOW > NOW INCORRECT - (C)");
+ ELSIF NOW >= LATER THEN
+ FAILED ("NOW >= LATER INCORRECT - (C)");
+ ELSIF NOW = LATER THEN
+ FAILED ("NOW = LATER INCORRECT - (C)");
+ END IF;
+
+ END; -- (C)
+
+ --------------------------------------------
+
+ DECLARE -- (D)
+
+ NOW, WAY_BACK_THEN : TIME;
+
+ BEGIN -- (D)
+
+ NOW := TIME_OF (2099, 12, 31);
+ WAY_BACK_THEN := TIME_OF (1901, 1, 1);
+
+ BEGIN
+ IF NOW < WAY_BACK_THEN THEN
+ FAILED ("TEST < AT EXTREMES INCORRECT - (D)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("< AT EXTREMES RAISED EXCEPTION - (D)");
+ END;
+
+ BEGIN
+ IF NOW <= WAY_BACK_THEN THEN
+ FAILED ("TEST <= AT EXTREMES INCORRECT - (D)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("<= AT EXTREMES RAISED EXCEPTION - (D)");
+ END;
+
+ BEGIN
+ IF WAY_BACK_THEN > NOW THEN
+ FAILED ("TEST > AT EXTREMES INCORRECT - (D)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("> AT EXTREMES RAISED EXCEPTION - (D)");
+ END;
+
+ BEGIN
+ IF WAY_BACK_THEN >= NOW THEN
+ FAILED ("TEST >= AT EXTREMES INCORRECT - (D)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED (">= AT EXTREMES RAISED EXCEPTION - (D)");
+ END;
+
+ BEGIN
+ IF WAY_BACK_THEN /= WAY_BACK_THEN THEN
+ FAILED ("TEST /= AT EXTREMES INCORRECT - (D)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("/= AT EXTREMES RAISED EXCEPTION - (D)");
+ END;
+
+ BEGIN
+ IF NOW = WAY_BACK_THEN THEN
+ FAILED ("TEST = AT EXTREMES INCORRECT - (D)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("= AT EXTREMES RAISED EXCEPTION - (D)");
+ END;
+
+ END; -- (D)
+
+ --------------------------------------------
+
+ RESULT;
+END C96006A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96007a.ada b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada
new file mode 100644
index 000000000..beda25fd5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada
@@ -0,0 +1,203 @@
+-- C96007A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED FOR THE TIME_OF()
+-- FUNCTION IN THE PACKAGE CALENDAR. PARTICULARLY,
+-- (A) TIME_ERROR IS RAISED ON INVALID DATES.
+-- (B) CONSTRAINT_ERROR IS RAISED FOR OUT-OF-RANGE PARAMETERS.
+
+-- CPP 8/16/84
+
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+PROCEDURE C96007A IS
+
+BEGIN
+ TEST ("C96007A", "CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED " &
+ "FOR THE TIME_OF FUNCTION IN THE PACKAGE CALENDAR");
+
+ --------------------------------------------
+
+ DECLARE -- (A)
+
+ BAD_TIME : TIME;
+
+ BEGIN -- (A)
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 2, 30);
+ FAILED ("EXCEPTION NOT RAISED - 2/30 (A)");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 2/30 (A)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 2, 31);
+ FAILED ("EXCEPTION NOT RAISED - 2/31 (A)");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 2/31 (A)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 4, 31);
+ FAILED ("EXCEPTION NOT RAISED - 4/31 (A)");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 4/31 (A)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 6, 31);
+ FAILED ("EXCEPTION NOT RAISED - 6/31 (A)");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 6/31 (A)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 9, 31);
+ FAILED ("EXCEPTION NOT RAISED - 9/31 (A)");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 9/31 (A)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 11, 31);
+ FAILED ("EXCEPTION NOT RAISED - 11/31 (A)");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 11/31 (A)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1983, 2, 29);
+ FAILED ("EXCEPTION NOT RAISED - 2/29 (A)");
+ EXCEPTION
+ WHEN TIME_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 2/29 (A)");
+ END;
+
+ END; -- (A)
+
+ --------------------------------------------
+
+ DECLARE -- (B)
+
+ BAD_TIME : TIME;
+
+ BEGIN -- (B)
+
+ BEGIN
+ BAD_TIME := TIME_OF (1900, 8, 13);
+ FAILED ("EXCEPTION NOT RAISED - 1900 (B)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 1900 (B)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (YEAR_NUMBER'LAST + 1, 8, 13);
+ FAILED ("EXCEPTION NOT RAISED - 2100 (B)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - 2100 (B)");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 0, 13);
+ FAILED ("EXCEPTION NOT RAISED - MONTH (B)1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - MONTH (B)1");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 13, 13);
+ FAILED ("EXCEPTION NOT RAISED - MONTH (B)2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - MONTH (B)2");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 8, 0);
+ FAILED ("EXCEPTION NOT RAISED - DAY (B)1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - DAY (B)1");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (19784, 8, 32);
+ FAILED ("EXCEPTION NOT RAISED - DAY (B)2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - DAY (B)2");
+ END;
+
+ BEGIN
+ BAD_TIME := TIME_OF (1984, 8, 13, -0.5);
+ FAILED ("EXCEPTION NOT RAISED - SECONDS (B)1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - SECONDS (B)1");
+ END;
+
+ END; -- (B)
+
+ --------------------------------------------
+
+ RESULT;
+END C96007A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96008a.ada b/gcc/testsuite/ada/acats/tests/c9/c96008a.ada
new file mode 100644
index 000000000..33b59d8c1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96008a.ada
@@ -0,0 +1,203 @@
+-- C96008A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE
+-- CALENDAR. SUBTESTS ARE:
+-- (A) TIME_OF() AND SPLIT() ARE INVERSE FUNCTIONS.
+-- (B) FORMAL PARAMETERS OF TIME_OF() AND SPLIT() ARE NAMED CORRECTLY.
+-- (C) TIME_OF() GIVES THE PARAMETER SECONDS A DEFAULT VALUE OF 0.0.
+-- (D) THE FUNCTIONS YEAR(), MONTH(), DAY(), AND SECONDS() RETURN
+-- CORRECT VALUES USING NAMED NOTATION.
+-- (E) A VALUE RETURNED FROM CLOCK() CAN BE PROCESSED BY SPLIT().
+-- (F) DURATION'SMALL MEETS REQUIRED LIMIT.
+
+-- CPP 8/16/84
+
+WITH SYSTEM;
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+PROCEDURE C96008A IS
+
+BEGIN
+ TEST ("C96008A", "CHECK MISCELLANEOUS FUNCTIONS IN THE " &
+ "PACKAGE CALENDAR");
+
+ ---------------------------------------------
+
+ DECLARE -- (A)
+ NOW : TIME;
+ YR : YEAR_NUMBER;
+ MO : MONTH_NUMBER;
+ DY : DAY_NUMBER;
+ SEC : DAY_DURATION;
+ BEGIN -- (A)
+ BEGIN
+ NOW := TIME_OF (1984, 8, 13, DURATION(1.0/3.0));
+ SPLIT (NOW, YR, MO, DY, SEC);
+ IF NOW /= TIME_OF (YR, MO, DY, SEC) THEN
+ COMMENT ("TIME_OF AND SPLIT ARE NOT INVERSES " &
+ "WHEN SECONDS IS A NON-MODEL NUMBER " &
+ "- (A)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("TIME_OF(SPLIT) RAISED EXCEPTION - (A)");
+ END;
+
+
+ BEGIN
+ -- RESET VALUES.
+ YR := 1984;
+ MO := 8;
+ DY := 13;
+ SEC := 1.0;
+
+ SPLIT (TIME_OF (YR, MO, DY, SEC), YR, MO, DY, SEC);
+
+ IF YR /= 1984 THEN
+ FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF YR - (A)");
+ END IF;
+
+ IF MO /= 8 THEN
+ FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF MO - (A)");
+ END IF;
+
+ IF DY /= 13 THEN
+ FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF DY - (A)");
+ END IF;
+
+ IF SEC /= 1.0 THEN
+ FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF " &
+ "SEC - (A)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("SPLIT(TIME_OF) PROCESSING RAISED " &
+ "EXCEPTION - (A)");
+ END;
+ END; -- (A)
+
+ ---------------------------------------------
+
+ BEGIN -- (B)
+ DECLARE
+ NOW : TIME;
+ BEGIN
+ NOW := TIME_OF (YEAR => 1984,
+ MONTH => 8,
+ DAY => 13,
+ SECONDS => 60.0);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("NAMED ASSOCIATION ON TIME_OF() RAISED " &
+ "EXCEPTION - (B)");
+ END;
+
+
+ DECLARE
+ NOW : TIME := CLOCK;
+ YR : YEAR_NUMBER := 1984;
+ MO : MONTH_NUMBER := 8;
+ DY : DAY_NUMBER := 13;
+ SEC : DAY_DURATION := 0.0;
+ BEGIN
+ SPLIT (DATE => NOW,
+ YEAR => YR,
+ MONTH => MO,
+ DAY => DY,
+ SECONDS => SEC);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("NAMED ASSOCIATION ON SPLIT() RAISED " &
+ "EXCEPTION - (B)2");
+ END;
+ END; -- (B)
+
+ ---------------------------------------------
+
+ DECLARE -- (C)
+ NOW : TIME;
+ BEGIN -- (C)
+ NOW := TIME_OF (1984, 8, 13);
+ IF SECONDS (NOW) /= 0.0 THEN
+ FAILED ("TIME_OF() DID NOT ZERO SECONDS - (C)");
+ END IF;
+ END; -- (C)
+
+ ---------------------------------------------
+
+ DECLARE -- (D)
+ -- ASSUMES TIME_OF() WORKS CORRECTLY.
+ HOLIDAY : TIME;
+ BEGIN -- (D)
+ HOLIDAY := TIME_OF (1958, 9, 9, 1.0);
+
+ IF YEAR (DATE => HOLIDAY) /= 1958 THEN
+ FAILED ("YEAR() DID NOT RETURN CORRECT VALUE - (D)");
+ END IF;
+
+ IF MONTH (DATE => HOLIDAY) /= 9 THEN
+ FAILED ("MONTH() DID NOT RETURN CORRECT VALUE - (D)");
+ END IF;
+
+ IF DAY (DATE => HOLIDAY) /= 9 THEN
+ FAILED ("DAY() DID NOT RETURN CORRECT VALUE - (D)");
+ END IF;
+
+ IF SECONDS (HOLIDAY) /= 1.0 THEN
+ FAILED ("SECONDS() DID NOT RETURN CORRECT VALUE - (D)");
+ END IF;
+ END; -- (D)
+
+ ---------------------------------------------
+
+ DECLARE -- (E)
+ YR : YEAR_NUMBER;
+ MO : MONTH_NUMBER;
+ DY : DAY_NUMBER;
+ SEC : DAY_DURATION;
+ BEGIN -- (E)
+ SPLIT (CLOCK, YR, MO, DY, SEC);
+ DELAY SYSTEM.TICK;
+
+ IF TIME_OF (YR, MO, DY, SEC) > CLOCK THEN
+ FAILED ("SPLIT() ON CLOCK INCORRECT - (E)");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("SPLIT() ON CLOCK RAISED EXCEPTION - (E)");
+ END; -- (E)
+
+ ---------------------------------------------
+
+ BEGIN -- (F)
+ IF DURATION'SMALL > 0.020 THEN
+ FAILED ("DURATION'SMALL LARGER THAN SPECIFIED - (F)");
+ END IF;
+ END; -- (F)
+
+ ---------------------------------------------
+
+ RESULT;
+END C96008A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c96008b.ada b/gcc/testsuite/ada/acats/tests/c9/c96008b.ada
new file mode 100644
index 000000000..7a23bcfb4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c96008b.ada
@@ -0,0 +1,71 @@
+-- C96008B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE
+-- CALENDAR. SUBTESTS ARE:
+-- (A) THE FUNCTION TIME_OF() MUST ADVANCE DAY WHEN CALLED WITH THE
+-- SECONDS ARGUMENT HAVING THE VALUE 86_400.
+
+-- CPP 8/16/84
+-- JRK 12/4/84
+
+WITH CALENDAR; USE CALENDAR;
+WITH REPORT; USE REPORT;
+PROCEDURE C96008B IS
+
+ NOW1, NOW2 : TIME;
+ YR : YEAR_NUMBER;
+ MO : MONTH_NUMBER;
+ DY : DAY_NUMBER;
+ SEC : DAY_DURATION;
+
+BEGIN
+
+ TEST ("C96008B", "CHECK THAT TIME_OF() ADVANCES DAY");
+
+ NOW1 := TIME_OF (1984, 8, 13, 86_400.0);
+ NOW2 := TIME_OF (1984, 8, 14, 0.0);
+
+ IF NOW1 /= NOW2 THEN
+ FAILED ("TIME_OF DID NOT CONVERT 86_400 SECONDS TO A DAY");
+ END IF;
+
+ SPLIT (NOW2, YR, MO, DY, SEC);
+
+ IF DY /= 14 THEN
+ FAILED ("DAY OF NOW2 INCORRECT");
+ END IF;
+ IF SEC /= 0.0 THEN
+ FAILED ("SECONDS OF NOW2 INCORRECT");
+ END IF;
+
+ SPLIT (NOW1, YR, MO, DY, SEC);
+
+ IF DY /= 14 OR SEC /= 0.0 OR
+ DAY (NOW1) /= 14 OR SECONDS (NOW1) /= 0.0 THEN
+ FAILED ("TIME_OF DID NOT ADVANCE DAY");
+ END IF;
+
+ RESULT;
+END C96008B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97112a.ada b/gcc/testsuite/ada/acats/tests/c9/c97112a.ada
new file mode 100644
index 000000000..ef7dca2d4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97112a.ada
@@ -0,0 +1,134 @@
+-- C97112A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A DELAY STATEMENT IS ALLOWED IN THE SEQUENCE OF STATEMENTS
+-- OF A SELECT ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A TERMINATE
+-- ALTERNATIVE OR AN ELSE PART.
+
+-- WRG 7/9/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97112A IS
+
+ ACCEPT_ALTERNATIVE_TAKEN : BOOLEAN := FALSE;
+
+BEGIN
+
+ TEST ("C97112A", "CHECK THAT A DELAY STATEMENT IS ALLOWED IN " &
+ "THE SEQUENCE OF STATEMENTS OF A SELECT " &
+ "ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A " &
+ "TERMINATE ALTERNATIVE OR AN ELSE PART");
+
+ --------------------------------------------------
+
+ A: DECLARE
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ BEFORE, AFTER : TIME;
+ BEGIN
+ SELECT
+ ACCEPT E;
+ ACCEPT_ALTERNATIVE_TAKEN := TRUE;
+ BEFORE := CLOCK;
+ DELAY 10.0 * Impdef.One_Second;
+ AFTER := CLOCK;
+ IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN
+ FAILED ("INSUFFICIENT DELAY (A)");
+ END IF;
+ OR
+ TERMINATE;
+ END SELECT;
+ END T;
+
+ BEGIN
+
+ T.E;
+
+ END A;
+
+ IF NOT ACCEPT_ALTERNATIVE_TAKEN THEN
+ FAILED ("ACCEPT ALTERNATIVE NOT TAKEN");
+ END IF;
+
+ --------------------------------------------------
+
+ B: DECLARE
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ BEFORE, AFTER : TIME;
+ BEGIN
+ --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING:
+ WHILE E'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ SELECT
+ ACCEPT E;
+ BEFORE := CLOCK;
+ DELAY 10.0 * Impdef.One_Second;
+ AFTER := CLOCK;
+ IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN
+ FAILED ("INSUFFICIENT DELAY (B-1)");
+ END IF;
+ ELSE
+ FAILED ("ELSE PART EXECUTED (B-1)");
+ END SELECT;
+
+ SELECT
+ ACCEPT E;
+ FAILED ("ACCEPT STATEMENT EXECUTED (B-2)");
+ ELSE
+ BEFORE := CLOCK;
+ DELAY 10.0 * Impdef.One_Second;
+ AFTER := CLOCK;
+ IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN
+ FAILED ("INSUFFICIENT DELAY (B-2)");
+ END IF;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED");
+ END T;
+
+ BEGIN
+
+ T.E;
+
+ END B;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C97112A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97113a.ada b/gcc/testsuite/ada/acats/tests/c9/c97113a.ada
new file mode 100644
index 000000000..f05d4380c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97113a.ada
@@ -0,0 +1,113 @@
+-- C97113A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ALL CONDITIONS, OPEN DELAY ALTERNATIVE EXPRESSIONS, AND
+-- OPEN ENTRY FAMILY INDICES ARE EVALUATED (EVEN WHEN SOME (PERHAPS
+-- ALL BUT ONE) OF THE ALTERNATIVES CAN BE RULED OUT WITHOUT
+-- COMPLETING THE EVALUATIONS).
+
+-- RM 5/06/82
+-- SPS 11/21/82
+-- WRG 7/9/86 ADDED DELAY EXPRESSIONS AND ENTRY FAMILY INDICES.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97113A IS
+
+ EXPR1_EVALUATED : BOOLEAN := FALSE;
+ EXPR2_EVALUATED : BOOLEAN := FALSE;
+ EXPR3_EVALUATED : BOOLEAN := FALSE;
+
+ FUNCTION F1 RETURN BOOLEAN IS
+ BEGIN
+ EXPR1_EVALUATED := TRUE;
+ RETURN TRUE;
+ END F1;
+
+ FUNCTION F2 (X : INTEGER) RETURN INTEGER IS
+ BEGIN
+ EXPR2_EVALUATED := TRUE;
+ RETURN X;
+ END F2;
+
+ FUNCTION F3 (X : DURATION) RETURN DURATION IS
+ BEGIN
+ EXPR3_EVALUATED := TRUE;
+ RETURN X;
+ END F3;
+
+BEGIN
+
+ TEST ("C97113A", "CHECK THAT ALL CONDITIONS, OPEN DELAY " &
+ "ALTERNATIVE EXPRESSIONS, AND OPEN ENTRY " &
+ "FAMILY INDICES ARE EVALUATED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E1;
+ ENTRY E2;
+ ENTRY E3 (1..1);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ --ENSURE THAT E1 HAS BEEN CALLED BEFORE PROCEEDING:
+ WHILE E1'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ SELECT
+ ACCEPT E1;
+ OR
+ WHEN F1 =>
+ ACCEPT E2;
+ OR
+ ACCEPT E3 ( F2(1) );
+ OR
+ DELAY F3 ( 1.0 ) * Impdef.One_Second;
+ END SELECT;
+ END T;
+
+ BEGIN
+
+ T.E1;
+
+ END;
+
+ IF NOT EXPR1_EVALUATED THEN
+ FAILED ("GUARD NOT EVALUATED");
+ END IF;
+
+ IF NOT EXPR2_EVALUATED THEN
+ FAILED ("ENTRY FAMILY INDEX NOT EVALUATED");
+ END IF;
+
+ IF NOT EXPR3_EVALUATED THEN
+ FAILED ("OPEN DELAY ALTERNATIVE EXPRESSION NOT EVALUATED");
+ END IF;
+
+ RESULT;
+
+END C97113A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97114a.ada b/gcc/testsuite/ada/acats/tests/c9/c97114a.ada
new file mode 100644
index 000000000..2a28fe8e8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97114a.ada
@@ -0,0 +1,196 @@
+-- C97114A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK WHETHER A DELAY EXPRESSION FOLLOWING AN OPEN GUARD IS EVALUATED
+-- DIRECTLY AFTER THE GUARD OR ONLY AFTER ALL GUARDS HAVE BEEN
+-- EVALUATED, OR IN SOME MIXED ORDER SUCH THAT DELAY EXPRESSIONS ARE
+-- EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE OPEN.
+
+-- RM 5/10/82
+-- SPS 11/21/82
+-- JBG 10/24/83
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97114A IS
+
+
+ -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST )
+
+ EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' );
+ EVAL_ORD : STRING (1..6) := ( 1..6 => '*' );
+ INDEX : INTEGER := 0;
+ DUMMY : INTEGER := 0;
+
+
+ FUNCTION F1 (X:INTEGER) RETURN INTEGER IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'F'; -- 123: FGH
+ EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' )
+ RETURN ( IDENT_INT(7) );
+ END F1;
+
+
+ FUNCTION F2 (X:INTEGER) RETURN INTEGER IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'G';
+ EVAL_ORD (INDEX) := 'G';
+ RETURN ( IDENT_INT(7) );
+ END F2;
+
+
+ FUNCTION F3 (X:INTEGER) RETURN INTEGER IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'H';
+ EVAL_ORD (INDEX) := 'G';
+ RETURN ( IDENT_INT(7) );
+ END F3;
+
+
+ FUNCTION D1( X:INTEGER ) RETURN DURATION IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'A'; -- 123: ABC
+ EVAL_ORD (INDEX) := 'D'; -- 123: DDD ( 'D' FOR 'DELAY' )
+ RETURN ( 1.0 );
+ END D1;
+
+
+ FUNCTION D2( X:INTEGER ) RETURN DURATION IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'B';
+ EVAL_ORD (INDEX) := 'D';
+ RETURN ( 2.0 );
+ END D2;
+
+
+ FUNCTION D3( X:INTEGER ) RETURN DURATION IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'C';
+ EVAL_ORD (INDEX) := 'D';
+ RETURN ( 3.0 );
+ END D3;
+
+ FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS
+ BEGIN
+ FOR I IN EVAL_ORDER'RANGE LOOP
+ IF EVAL_ORDER(I) = FUNC THEN
+ RETURN I;
+ END IF;
+ END LOOP;
+ FAILED ("DID NOT FIND LETTER " & FUNC);
+ RETURN 0;
+ END POS_OF;
+
+BEGIN
+
+
+ TEST ("C97114A", "CHECK THAT THE DELAY EXPRESSIONS ARE" &
+ " EVALUATED AFTER THE GUARDS BUT" &
+ " BEFORE THE RENDEZVOUS IS ATTEMPTED" );
+
+
+ DECLARE
+
+
+ TASK T IS
+
+
+ ENTRY E1;
+
+ END T;
+
+
+ TASK BODY T IS
+ BEGIN
+
+
+ WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE
+ LOOP -- THE MAIN TASK AN OPPORTUNITY
+ DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL.
+ END LOOP;
+
+
+ SELECT
+
+ ACCEPT E1;
+
+ OR
+
+ WHEN 6 + F1(7) = 13 =>
+ DELAY D1( DUMMY ) * Impdef.One_Second;
+
+ OR
+
+ WHEN 6 + F2(7) = 13 =>
+ DELAY D2( DUMMY ) * Impdef.One_Second;
+
+ OR
+
+ WHEN 6 + F3(7) = 13 =>
+ DELAY D3( DUMMY ) * Impdef.One_Second;
+
+ END SELECT;
+
+
+ END T;
+
+
+ BEGIN
+
+ T.E1;
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALLS
+
+
+ COMMENT ("EVALUATIONS WERE DONE IN THE ORDER " & EVAL_ORD);
+ COMMENT ("FUNCTIONS WERE CALLED IN THE ORDER " & EVAL_ORDER);
+
+ IF EVAL_ORD = "GGGDDD" THEN
+ COMMENT ("ALL GUARDS EVALUATED FIRST");
+ ELSIF EVAL_ORD = "GDGDGD" THEN
+ COMMENT ("DELAY EXPRESSION EVALUATED AFTER EACH GUARD");
+ END IF;
+
+-- CHECK THAT GUARDS ARE ALWAYS EVALUATED BEFORE DELAY EXPRESSIONS
+
+ IF POS_OF ('F') > POS_OF ('A') OR
+ POS_OF ('G') > POS_OF ('B') OR
+ POS_OF ('H') > POS_OF ('C') THEN
+ FAILED ("A DELAY EXPRESSION WAS EVALUATED BEFORE ITS " &
+ "GUARD");
+ END IF;
+
+
+ RESULT;
+
+
+END C97114A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97115a.ada b/gcc/testsuite/ada/acats/tests/c9/c97115a.ada
new file mode 100644
index 000000000..8e9845ea6
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97115a.ada
@@ -0,0 +1,189 @@
+-- C97115A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK WHETHER AN ENTRY FAMILY INDEX EXPRESSION FOLLOWING AN OPEN
+-- GUARD IS EVALUATED DIRECTLY AFTER THE GUARD, OR ONLY AFTER ALL GUARDS
+-- HAVE BEEN EVALUATED, OR IN SOME MIXED ORDER SUCH THAT INDEX
+-- EXPRESSIONS ARE EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE
+-- OPEN.
+
+-- RM 5/11/82
+-- SPS 11/21/82
+-- JBG 10/24/83
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97115A IS
+
+
+ -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST )
+
+ EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' );
+ EVAL_ORD : STRING (1..6) := ( 1..6 => '*' );
+ INDEX : INTEGER := 0;
+
+
+ FUNCTION F1 (X:INTEGER) RETURN INTEGER IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'F'; -- 123: FGH
+ EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' )
+ RETURN ( IDENT_INT(7) );
+ END F1;
+
+
+ FUNCTION F2 (X:INTEGER) RETURN INTEGER IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'G';
+ EVAL_ORD (INDEX) := 'G';
+ RETURN ( IDENT_INT(7) );
+ END F2;
+
+
+ FUNCTION F3 (X:INTEGER) RETURN INTEGER IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'H';
+ EVAL_ORD (INDEX) := 'G';
+ RETURN ( IDENT_INT(7) );
+ END F3;
+
+
+ FUNCTION I1 ( X:INTEGER ) RETURN BOOLEAN IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'A'; -- 123: ABC
+ EVAL_ORD (INDEX) := 'I'; -- 123: III ( 'I' FOR 'INDEX' )
+ RETURN ( IDENT_BOOL(TRUE) ); -- (THAT'S ENTRY-FAMILY INDEX)
+ END I1;
+
+
+ FUNCTION I2 ( X:INTEGER ) RETURN BOOLEAN IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'B';
+ EVAL_ORD (INDEX) := 'I';
+ RETURN ( IDENT_BOOL(TRUE) );
+ END I2;
+
+
+ FUNCTION I3 ( X:INTEGER ) RETURN BOOLEAN IS
+ BEGIN
+ INDEX := INDEX + 1;
+ EVAL_ORDER (INDEX) := 'C';
+ EVAL_ORD (INDEX) := 'I';
+ RETURN ( IDENT_BOOL(TRUE) );
+ END I3;
+
+ FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS
+ BEGIN
+ FOR I IN EVAL_ORDER'RANGE LOOP
+ IF EVAL_ORDER(I) = FUNC THEN
+ RETURN I;
+ END IF;
+ END LOOP;
+ FAILED ("DID NOT FIND LETTER " & FUNC);
+ RETURN 0;
+ END POS_OF;
+
+
+BEGIN
+
+
+ TEST ("C97115A", "CHECK THAT THE INDEX EXPRESSIONS ARE" &
+ " EVALUATED AFTER THE GUARDS BUT" &
+ " BEFORE THE RENDEZVOUS IS ATTEMPTED" );
+
+
+ DECLARE
+
+
+ TASK T IS
+
+
+ ENTRY E ( BOOLEAN );
+ ENTRY E1;
+
+ END T;
+
+
+ TASK BODY T IS
+ BEGIN
+
+
+ WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE
+ LOOP -- THE MAIN TASK AN OPPORTUNITY
+ DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL.
+ END LOOP;
+
+
+ SELECT
+
+ ACCEPT E1;
+
+ OR
+
+ WHEN 6 + F1(7) = 13 =>
+ ACCEPT E ( I1(17) );
+
+ OR
+
+ WHEN 6 + F2(7) = 13 =>
+ ACCEPT E ( I2(17) );
+
+ OR
+
+ WHEN 6 + F3(7) = 13 =>
+ ACCEPT E ( I3(17) );
+
+ END SELECT;
+
+
+ END T;
+
+
+ BEGIN
+
+ T.E1;
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALLS
+
+
+ COMMENT ("GUARD AND INDEX FUNCTIONS WERE CALLED IN ORDER " &
+ EVAL_ORDER);
+ COMMENT ("GUARD AND INDEX EXPRESSIONS WERE EVALUATED IN THE " &
+ "ORDER " & EVAL_ORD);
+
+ IF POS_OF ('F') > POS_OF ('A') OR
+ POS_OF ('G') > POS_OF ('B') OR
+ POS_OF ('H') > POS_OF ('C') THEN
+ FAILED ("AN INDEX EXPRESSION WAS EVALUATED TOO EARLY");
+ END IF;
+
+ RESULT;
+
+END C97115A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97116a.ada b/gcc/testsuite/ada/acats/tests/c9/c97116a.ada
new file mode 100644
index 000000000..737d2528e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97116a.ada
@@ -0,0 +1,102 @@
+-- C97116A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT THE GUARD CONDITIONS IN A SELECTIVE WAIT STATEMENT
+-- ARE NOT RE-EVALUATED DURING THE WAIT.
+
+-- HISTORY:
+-- WRG 7/10/86 CREATED ORIGINAL TEST.
+-- RJW 5/15/90 REMOVED SHARED VARIABLES.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97116A IS
+
+ GUARD_EVALUATIONS : NATURAL := 0;
+
+ FUNCTION GUARD RETURN BOOLEAN IS
+ BEGIN
+ GUARD_EVALUATIONS := GUARD_EVALUATIONS + 1;
+ RETURN FALSE;
+ END GUARD;
+
+ FUNCTION SO_LONG RETURN DURATION IS
+ BEGIN
+ RETURN 20.0;
+ END SO_LONG;
+
+BEGIN
+
+ TEST ("C97116A", "CHECK THAT THE GUARD CONDITIONS IN A " &
+ "SELECTIVE WAIT STATEMENT ARE NOT RE-EVALUATED " &
+ "DURING THE WAIT");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E;
+ FAILED ("ACCEPTED NONEXISTENT CALL TO E");
+ OR WHEN GUARD =>
+ DELAY 0.0;
+ FAILED ("EXECUTED ALTERNATIVE CLOSED BY FALSE " &
+ "GUARD FUNCTION" );
+ OR
+ DELAY SO_LONG * Impdef.One_Second;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED");
+ END T;
+
+ TASK GET_CPU;
+
+ TASK BODY GET_CPU IS
+ BEGIN
+ WHILE NOT T'TERMINATED LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ END GET_CPU;
+
+ BEGIN
+
+ NULL;
+
+ END;
+
+ IF GUARD_EVALUATIONS /= 1 THEN
+ FAILED ("GUARD EVALUATED" &
+ NATURAL'IMAGE(GUARD_EVALUATIONS) & " TIMES");
+ END IF;
+
+ RESULT;
+
+END C97116A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117a.ada b/gcc/testsuite/ada/acats/tests/c9/c97117a.ada
new file mode 100644
index 000000000..cf5e1b911
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97117a.ada
@@ -0,0 +1,72 @@
+-- C97117A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT PROGRAM_ERROR IS RAISED IF ALL ALTERNATIVES ARE CLOSED AND
+-- NO ELSE PART IS PRESENT.
+
+-- WRG 7/10/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97117A IS
+
+BEGIN
+
+ TEST ("C97117A", "CHECK THAT PROGRAM_ERROR IS RAISED IF ALL " &
+ "ALTERNATIVES ARE CLOSED AND NO ELSE PART IS " &
+ "PRESENT");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ WHEN IDENT_BOOL (FALSE) =>
+ ACCEPT E;
+ FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " &
+ "FOR NONEXISTENT ENTRY CALL");
+ OR WHEN IDENT_BOOL (FALSE) =>
+ DELAY 0.0;
+ FAILED ("CLOSED ALTERNATIVE TAKEN");
+ END SELECT;
+ FAILED ("PROGRAM_ERROR NOT RAISED");
+ EXCEPTION
+ WHEN PROGRAM_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END T;
+
+ BEGIN
+
+ NULL;
+
+ END;
+
+ RESULT;
+
+END C97117A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117b.ada b/gcc/testsuite/ada/acats/tests/c9/c97117b.ada
new file mode 100644
index 000000000..bc05ebf35
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97117b.ada
@@ -0,0 +1,88 @@
+-- C97117B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT AN ELSE PART IS EXECUTED IF ALL ALTERNATIVES ARE CLOSED OR
+-- IF THERE ARE NO TASKS QUEUED FOR OPEN ALTERNATIVES.
+
+-- WRG 7/10/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97117B IS
+
+BEGIN
+
+ TEST ("C97117B", "CHECK THAT AN ELSE PART IS EXECUTED IF ALL " &
+ "ALTERNATIVES ARE CLOSED OR IF THERE ARE NO " &
+ "TASKS QUEUED FOR OPEN ALTERNATIVES");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ ENTRY NO_GO;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ -- ENSURE THAT NO_GO HAS BEEN CALLED BEFORE PROCEEDING:
+ WHILE NO_GO'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ SELECT
+ WHEN IDENT_BOOL (FALSE) =>
+ ACCEPT E;
+ FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " &
+ "FOR NONEXISTENT ENTRY CALL - 1");
+ OR
+ WHEN IDENT_BOOL (FALSE) =>
+ ACCEPT NO_GO;
+ FAILED ("CLOSED ALTERNATIVE TAKEN - 1");
+ ELSE
+ COMMENT ("ELSE PART EXECUTED - 1");
+ END SELECT;
+
+ SELECT
+ ACCEPT E;
+ FAILED ("ACCEPTED NONEXISTENT ENTRY CALL - 2");
+ OR WHEN IDENT_BOOL (FALSE) =>
+ ACCEPT NO_GO;
+ FAILED ("CLOSED ALTERNATIVE TAKEN - 2");
+ ELSE
+ COMMENT ("ELSE PART EXECUTED - 2");
+ END SELECT;
+
+ ACCEPT NO_GO;
+ END T;
+
+ BEGIN
+
+ T.NO_GO;
+
+ END;
+
+ RESULT;
+
+END C97117B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117c.ada b/gcc/testsuite/ada/acats/tests/c9/c97117c.ada
new file mode 100644
index 000000000..cda428029
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97117c.ada
@@ -0,0 +1,74 @@
+-- C97117C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT AN ELSE PART IS NOT EXECUTED IF A TASK IS QUEUED AT AN
+-- OPEN ALTERNATIVE.
+
+-- WRG 7/10/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97117C IS
+
+BEGIN
+
+ TEST ("C97117C", "CHECK THAT AN ELSE PART IS NOT EXECUTED IF A " &
+ "TASK IS QUEUED AT AN OPEN ALTERNATIVE");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ ENTRY NO_GO;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING:
+ WHILE E'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ SELECT
+ ACCEPT NO_GO;
+ FAILED ("ACCEPTED NONEXISTENT ENTRY CALL");
+ OR WHEN IDENT_BOOL (TRUE) =>
+ ACCEPT E;
+ OR WHEN IDENT_BOOL (FALSE) =>
+ ACCEPT E;
+ FAILED ("CLOSED ALTERNATIVE TAKEN");
+ ELSE
+ FAILED ("ELSE PART EXECUTED");
+ END SELECT;
+ END T;
+
+ BEGIN
+
+ T.E;
+
+ END;
+
+ RESULT;
+
+END C97117C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97118a.ada b/gcc/testsuite/ada/acats/tests/c9/c97118a.ada
new file mode 100644
index 000000000..e1eceaf67
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97118a.ada
@@ -0,0 +1,73 @@
+-- C97118A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF A SELECTIVE WAIT IS NOT
+-- ACCEPTED.
+
+-- WRG 7/11/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97118A IS
+
+BEGIN
+
+ TEST ("C97118A", "CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF " &
+ "A SELECTIVE WAIT IS NOT ACCEPTED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING:
+ WHILE E'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ SELECT
+ WHEN IDENT_BOOL (FALSE) =>
+ ACCEPT E;
+ FAILED ("ACCEPTED CALL TO CLOSED ALTERNATIVE");
+ ELSE
+ NULL;
+ END SELECT;
+
+ IF E'COUNT = 1 THEN
+ ACCEPT E;
+ END IF;
+ END T;
+
+ BEGIN
+
+ T.E;
+
+ END;
+
+ RESULT;
+
+END C97118A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97120a.ada b/gcc/testsuite/ada/acats/tests/c9/c97120a.ada
new file mode 100644
index 000000000..4fd5293c1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97120a.ada
@@ -0,0 +1,81 @@
+-- C97120A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST AS LONG AS IS SPECIFIED
+-- IN A DELAY ALTERNATIVE.
+
+-- WRG 7/11/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97120A IS
+
+BEGIN
+
+ TEST ("C97120A", "CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST " &
+ "AS LONG AS IS SPECIFIED IN A DELAY ALTERNATIVE");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY NO_GO;
+ ENTRY SYNCH;
+ END T;
+
+ TASK BODY T IS
+ BEFORE, AFTER : TIME;
+ BEGIN
+ -- ENSURE THAT SYNCH HAS BEEN CALLED BEFORE PROCEEDING:
+ WHILE SYNCH'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ BEFORE := CLOCK;
+ SELECT
+ ACCEPT NO_GO;
+ FAILED ("ACCEPTED NONEXISTENT ENTRY CALL");
+ OR
+ DELAY 10.0 * Impdef.One_Second;
+ AFTER := CLOCK;
+ IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN
+ FAILED ("INSUFFICIENT DELAY");
+ END IF;
+ END SELECT;
+
+ ACCEPT SYNCH;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED");
+ END T;
+
+ BEGIN
+
+ T.SYNCH; -- SUSPEND MAIN TASK BEFORE READING CLOCK.
+
+ END;
+
+ RESULT;
+
+END C97120A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97120b.ada b/gcc/testsuite/ada/acats/tests/c9/c97120b.ada
new file mode 100644
index 000000000..5cc9806bb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97120b.ada
@@ -0,0 +1,103 @@
+-- C97120B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF A SPECIFIED DELAY IS ZERO OR NEGATIVE AND AN ENTRY CALL
+-- IS WAITING AT AN OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS
+-- EXECUTED, THE CALL IS ACCEPTED.
+
+-- WRG 7/11/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97120B IS
+
+ ZERO, NEG : DURATION := 1.0;
+
+BEGIN
+
+ TEST ("C97120B", "CHECK THAT IF A SPECIFIED DELAY IS ZERO OR " &
+ "NEGATIVE AND AN ENTRY CALL IS WAITING AT AN " &
+ "OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS " &
+ "EXECUTED, THE CALL IS ACCEPTED");
+
+ IF EQUAL (3, 3) THEN
+ ZERO := 0.0;
+ NEG := -1.0;
+ END IF;
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ WHILE E'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ A: BEGIN
+ SELECT
+ WHEN IDENT_BOOL (TRUE) =>
+ ACCEPT E;
+ OR
+ DELAY ZERO * Impdef.One_Second;
+ FAILED ("ZERO DELAY ALTERNATIVE TAKEN");
+ ACCEPT E;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED (A)");
+ END A;
+
+ WHILE E'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ B: BEGIN
+ SELECT
+ ACCEPT E;
+ OR
+ DELAY NEG;
+ FAILED ("NEGATIVE DELAY ALTERNATIVE TAKEN");
+ ACCEPT E;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED (B)");
+ END B;
+
+ END T;
+
+ BEGIN
+
+ T.E;
+ T.E;
+
+ END;
+
+ RESULT;
+
+END C97120B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201a.ada b/gcc/testsuite/ada/acats/tests/c9/c97201a.ada
new file mode 100644
index 000000000..18186cbc3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201a.ada
@@ -0,0 +1,151 @@
+-- C97201A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL
+-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE.
+
+-- CASE A: THE TASK TO BE CALLED IS NOT YET ACTIVE AS OF THE
+-- MOMENT OF CALL (CONDITIONAL_ENTRY_CALL),
+-- AND THIS FACT CAN BE DETERMINED STATICALLY.
+
+
+-- RM 4/20/82
+
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97201A IS
+
+ ELSE_BRANCH_TAKEN : INTEGER := 3 ;
+
+BEGIN
+
+
+ TEST ("C97201A", "CHECK THAT NO RENDEZVOUS REQUESTED BY" &
+ " A CONDITIONAL_ENTRY_CALL CAN OCCUR WHILE" &
+ " THE CALLED TASK IS NOT YET ACTIVE" );
+
+
+ -------------------------------------------------------------------
+
+
+ DECLARE
+
+
+ TASK T IS
+ ENTRY DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) ;
+ END T ;
+
+
+ TASK BODY T IS
+
+ PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT ;
+ PACKAGE BODY SECOND_ATTEMPT IS
+ BEGIN
+
+ SELECT
+ DO_IT_NOW_ORELSE (FALSE) ;--CALLING (OWN) ENTRY
+ ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY)
+ -- THEREFORE THIS BRANCH MUST BE CHOSEN
+ ELSE_BRANCH_TAKEN := 2 * ELSE_BRANCH_TAKEN ;
+ COMMENT( "ELSE_BRANCH TAKEN (#2)" );
+ END SELECT;
+
+ END SECOND_ATTEMPT ;
+
+ BEGIN
+
+ ACCEPT DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) DO
+
+ IF AUTHORIZED THEN
+ COMMENT( "AUTHORIZED ENTRY_CALL" );
+ ELSE
+ FAILED( "UNAUTHORIZED ENTRY_CALL" );
+ END IF;
+
+ END DO_IT_NOW_ORELSE ;
+
+
+ END T ;
+
+
+ PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT ;
+ PACKAGE BODY FIRST_ATTEMPT IS
+ BEGIN
+ SELECT
+ T.DO_IT_NOW_ORELSE (FALSE) ;
+ ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY)
+ -- THEREFORE THIS BRANCH MUST BE CHOSEN
+ ELSE_BRANCH_TAKEN := 1 + ELSE_BRANCH_TAKEN ;
+ COMMENT( "ELSE_BRANCH TAKEN (#1)" );
+ END SELECT;
+
+ END FIRST_ATTEMPT ;
+
+
+ BEGIN
+
+ T.DO_IT_NOW_ORELSE ( TRUE ); -- TO SATISFY THE SERVER'S
+ -- WAIT FOR SUCH A CALL
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ FAILED( "TASKING ERROR" );
+
+ END ;
+
+
+ -------------------------------------------------------------------
+
+
+ -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED)
+
+
+ CASE ELSE_BRANCH_TAKEN IS
+
+ WHEN 3 =>
+ FAILED( "NO 'ELSE'; BOTH (?) RENDEZVOUS ATTEMPTED?" );
+
+ WHEN 4 =>
+ FAILED( "'ELSE' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" );
+
+ WHEN 6 =>
+ FAILED( "'ELSE' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" );
+
+ WHEN 7 =>
+ FAILED( "WRONG ORDER FOR 'ELSE': #2,#1 " );
+
+ WHEN 8 =>
+ NULL ;
+
+ WHEN OTHERS =>
+ FAILED( "WRONG CASE_VALUE" );
+
+ END CASE;
+
+
+ RESULT;
+
+
+END C97201A ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201b.ada b/gcc/testsuite/ada/acats/tests/c9/c97201b.ada
new file mode 100644
index 000000000..d8e44b055
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201b.ada
@@ -0,0 +1,108 @@
+-- C97201B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF THERE IS
+-- ANOTHER TASK QUEUED FOR THE ENTRY.
+
+-- WRG 7/11/86
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97201B IS
+
+
+BEGIN
+
+ TEST ("C97201B", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " &
+ "ACCEPTED IF THERE IS ANOTHER TASK QUEUED " &
+ "FOR THE ENTRY");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ ENTRY SYNCH;
+ ENTRY DONE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING:
+ WHILE E'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+
+ ACCEPT SYNCH;
+
+ SELECT
+ WHEN IDENT_BOOL (FALSE) =>
+ ACCEPT E;
+ FAILED ("CLOSED ALTERNATIVE TAKEN");
+ OR
+ ACCEPT DONE DO
+ IF E'COUNT /= 1 THEN
+ FAILED (NATURAL'IMAGE(E'COUNT) &
+ " CALLS WERE QUEUED FOR ENTRY " &
+ "E OF TASK T");
+ END IF;
+ END DONE;
+ OR
+ DELAY 1000.0 * Impdef.One_Second;
+ FAILED ("DELAY EXPIRED; E'COUNT =" &
+ NATURAL'IMAGE(E'COUNT) );
+ END SELECT;
+
+ WHILE E'COUNT > 0 LOOP
+ ACCEPT E;
+ END LOOP;
+ END T;
+
+ TASK AGENT;
+
+ TASK BODY AGENT IS
+ BEGIN
+ T.E;
+ END AGENT;
+
+ BEGIN
+
+ T.SYNCH;
+
+ DELAY 10.0 * Impdef.One_Second;
+
+ SELECT
+ T.E;
+ FAILED ("CONDITIONAL ENTRY CALL ACCEPTED" );
+ ELSE
+ COMMENT ("ELSE PART EXECUTED");
+ T.DONE;
+ END SELECT;
+
+ END;
+
+ RESULT;
+
+END C97201B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201c.ada b/gcc/testsuite/ada/acats/tests/c9/c97201c.ada
new file mode 100644
index 000000000..e09d01ee3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201c.ada
@@ -0,0 +1,70 @@
+-- C97201C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF AN ACCEPT
+-- STATEMENT FOR THE CALLED ENTRY HAS NOT YET BEEN REACHED.
+
+-- WRG 7/11/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97201C IS
+
+BEGIN
+
+ TEST ("C97201C", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " &
+ "ACCEPTED IF AN ACCEPT STATEMENT FOR THE " &
+ "CALLED ENTRY HAS NOT YET BEEN REACHED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ ENTRY BARRIER;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT BARRIER;
+ IF E'COUNT > 0 THEN
+ FAILED ("ENTRY CALL WAS QUEUED");
+ ACCEPT E;
+ END IF;
+ END T;
+
+ BEGIN
+
+ SELECT
+ T.E;
+ FAILED ("CONDITIONAL ENTRY CALL ACCEPTED");
+ ELSE
+ COMMENT ("ELSE PART EXECUTED");
+ END SELECT;
+
+ T.BARRIER;
+
+ END;
+
+ RESULT;
+
+END C97201C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201d.ada b/gcc/testsuite/ada/acats/tests/c9/c97201d.ada
new file mode 100644
index 000000000..2ea7ba01a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201d.ada
@@ -0,0 +1,102 @@
+-- C97201D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL
+-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE.
+
+-- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY
+-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY -
+-- AND THIS FACT IS DETERMINED STATICALLY.
+
+
+-- RM 4/12/82
+
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97201D IS
+
+ ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ;
+
+BEGIN
+
+
+ TEST ("C97201D", "CHECK THAT NO RENDEZVOUS REQUESTED BY" &
+ " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" &
+ " IN THE ABSENCE OF A CORRESPONDING " &
+ " ACCEPT_STATEMENT " );
+
+
+ DECLARE
+
+
+ TASK T IS
+ ENTRY DO_IT_NOW_ORELSE ;
+ ENTRY KEEP_ALIVE ;
+ END T ;
+
+
+ TASK BODY T IS
+ BEGIN
+
+ -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED
+
+ ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM
+ -- TERMINATING IF
+ -- UPON ACTIVATION
+ -- IT GETS TO RUN
+ -- AHEAD OF THE CALLER (WHICH
+ -- WOULD LEAD TO A SUBSEQUENT
+ -- TASKING_ERROR AT THE TIME OF
+ -- THE NO-WAIT CALL).
+
+ END ;
+
+
+ BEGIN
+
+ SELECT
+ T.DO_IT_NOW_ORELSE ;
+ ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY)
+ -- THEREFORE THIS BRANCH MUST BE CHOSEN
+ ELSE_BRANCH_TAKEN := TRUE ;
+ COMMENT( "ELSE_BRANCH TAKEN" );
+ END SELECT;
+
+ T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALL
+
+
+ -- BY NOW, THE TASK IS TERMINATED
+
+ IF ELSE_BRANCH_TAKEN THEN
+ NULL ;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED?" );
+ END IF;
+
+ RESULT;
+
+
+END C97201D ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201e.ada b/gcc/testsuite/ada/acats/tests/c9/c97201e.ada
new file mode 100644
index 000000000..5473b572a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201e.ada
@@ -0,0 +1,107 @@
+-- C97201E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL
+-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE.
+
+-- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY
+-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY -
+-- AND THIS FACT CAN NOT BE DETERMINED STATICALLY.
+-- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS
+-- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.)
+
+
+-- RM 4/13/82
+
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97201E IS
+
+ ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ;
+
+BEGIN
+
+
+ TEST ("C97201E", "CHECK THAT NO RENDEZVOUS REQUESTED BY" &
+ " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" &
+ " IN THE ABSENCE OF A CORRESPONDING " &
+ " ACCEPT_STATEMENT " );
+
+
+ DECLARE
+
+ SUBTYPE SHORT IS INTEGER RANGE 10..20 ;
+
+ KEEP_ALIVE : INTEGER := 15 ;
+
+ TASK T IS
+ ENTRY DO_IT_NOW_ORELSE ( SHORT ) ;
+ END T ;
+
+
+ TASK BODY T IS
+ BEGIN
+
+ -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED
+ ACCEPT DO_IT_NOW_ORELSE ( IDENT_INT(15) );
+
+ -- THIS ALSO PREVENTS THIS SERVER
+ -- TASK FROM TERMINATING IF
+ -- UPON ACTIVATION
+ -- IT GETS TO RUN
+ -- AHEAD OF THE CALLER (WHICH
+ -- WOULD LEAD TO A SUBSEQUENT
+ -- TASKING_ERROR AT THE TIME OF
+ -- THE NO-WAIT CALL).
+
+ END ;
+
+
+ BEGIN
+
+ SELECT
+ T.DO_IT_NOW_ORELSE (10) ; -- ACCEPT_STATEMENT HAS 15
+ ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY)
+ -- THEREFORE THIS BRANCH MUST BE CHOSEN
+ ELSE_BRANCH_TAKEN := TRUE ;
+ COMMENT( "ELSE_BRANCH TAKEN" );
+ END SELECT;
+
+ T.DO_IT_NOW_ORELSE(KEEP_ALIVE) ;-- THIS ALSO UPDATES NONLOCALS
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALL
+
+
+ -- BY NOW, THE TASK IS TERMINATED
+
+ IF ELSE_BRANCH_TAKEN THEN
+ NULL ;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED?" );
+ END IF;
+
+ RESULT;
+
+
+END C97201E ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201g.ada b/gcc/testsuite/ada/acats/tests/c9/c97201g.ada
new file mode 100644
index 000000000..ae5fad3bc
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201g.ada
@@ -0,0 +1,133 @@
+-- C97201G.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL
+-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE.
+
+-- CASE G: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED
+-- AND THIS FACT IS STATICALLY DETERMINABLE.
+
+
+-- RM 4/21/82
+
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97201G IS
+
+ ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ;
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ;
+ QUEUE_NOT_EMPTY : BOOLEAN := FALSE ;
+ X : INTEGER := 17 ;
+
+BEGIN
+
+
+ TEST ("C97201G", "CHECK THAT NO RENDEZVOUS REQUESTED BY" &
+ " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" &
+ " IF THE CORRESPONDING ACCEPT_STATEMENT IS" &
+ " CLOSED" );
+
+
+ -------------------------------------------------------------------
+
+
+ DECLARE
+
+
+ TASK T IS
+ ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN);
+ ENTRY KEEP_ALIVE ;
+ END T ;
+
+
+ TASK BODY T IS
+ BEGIN
+
+ IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN
+ QUEUE_NOT_EMPTY := TRUE ;
+ END IF;
+
+
+ SELECT
+ WHEN 3 = 5 =>
+ ACCEPT DO_IT_NOW_ORELSE
+ ( DID_YOU_DO_IT : IN OUT BOOLEAN)
+ DO
+ DID_YOU_DO_IT := TRUE ;
+ END;
+ OR
+ ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR
+ END SELECT;
+
+
+ IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN
+ QUEUE_NOT_EMPTY := TRUE ;
+ END IF;
+
+
+ END T ;
+
+
+ BEGIN
+
+ COMMENT( "PERMANENTLY CLOSED" );
+
+ SELECT
+ T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED );
+ ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY)
+ -- THEREFORE THIS BRANCH MUST BE CHOSEN
+ ELSE_BRANCH_TAKEN := TRUE ;
+ COMMENT( "ELSE_BRANCH TAKEN" );
+ END SELECT;
+
+ T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALL
+
+
+ -------------------------------------------------------------------
+
+
+ -- BY NOW, THE TASK IS TERMINATED
+
+ IF RENDEZVOUS_OCCURRED
+ THEN
+ FAILED( "RENDEZVOUS OCCURRED" );
+ END IF;
+
+ IF QUEUE_NOT_EMPTY
+ THEN
+ FAILED( "ENTRY QUEUE NOT EMPTY" );
+ END IF;
+
+ IF ELSE_BRANCH_TAKEN THEN
+ NULL ;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED?" );
+ END IF;
+
+ RESULT;
+
+
+END C97201G ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201h.ada b/gcc/testsuite/ada/acats/tests/c9/c97201h.ada
new file mode 100644
index 000000000..ad4a46189
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201h.ada
@@ -0,0 +1,133 @@
+-- C97201H.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL
+-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE.
+
+-- CASE H: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED
+-- AND THIS FACT IS NOT STATICALLY DETERMINABLE.
+
+
+-- RM 4/22/82
+
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97201H IS
+
+ ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ;
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ;
+ QUEUE_NOT_EMPTY : BOOLEAN := FALSE ;
+ X : INTEGER := 17 ;
+
+BEGIN
+
+
+ TEST ("C97201H", "CHECK THAT NO RENDEZVOUS REQUESTED BY" &
+ " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" &
+ " IF THE CORRESPONDING ACCEPT_STATEMENT IS" &
+ " CLOSED" );
+
+
+ -------------------------------------------------------------------
+
+
+ DECLARE
+
+
+ TASK T IS
+ ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN);
+ ENTRY KEEP_ALIVE ;
+ END T ;
+
+
+ TASK BODY T IS
+ BEGIN
+
+ IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN
+ QUEUE_NOT_EMPTY := TRUE ;
+ END IF;
+
+
+ SELECT
+ WHEN 3 = IDENT_INT(5) =>
+ ACCEPT DO_IT_NOW_ORELSE
+ ( DID_YOU_DO_IT : IN OUT BOOLEAN)
+ DO
+ DID_YOU_DO_IT := TRUE ;
+ END;
+ OR
+ ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR
+ END SELECT;
+
+
+ IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN
+ QUEUE_NOT_EMPTY := TRUE ;
+ END IF;
+
+
+ END T ;
+
+
+ BEGIN
+
+ COMMENT( "PERMANENTLY CLOSED" );
+
+ SELECT
+ T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED );
+ ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY)
+ -- THEREFORE THIS BRANCH MUST BE CHOSEN
+ ELSE_BRANCH_TAKEN := TRUE ;
+ COMMENT( "ELSE_BRANCH TAKEN" );
+ END SELECT;
+
+ T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALL
+
+
+ -------------------------------------------------------------------
+
+
+ -- BY NOW, THE TASK IS TERMINATED
+
+ IF RENDEZVOUS_OCCURRED
+ THEN
+ FAILED( "RENDEZVOUS OCCURRED" );
+ END IF;
+
+ IF QUEUE_NOT_EMPTY
+ THEN
+ FAILED( "ENTRY QUEUE NOT EMPTY" );
+ END IF;
+
+ IF ELSE_BRANCH_TAKEN THEN
+ NULL ;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED?" );
+ END IF;
+
+ RESULT;
+
+
+END C97201H ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201x.ada b/gcc/testsuite/ada/acats/tests/c9/c97201x.ada
new file mode 100644
index 000000000..e7f74d982
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97201x.ada
@@ -0,0 +1,170 @@
+-- C97201X.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF BOTH PARTNERS REFUSE TO
+-- WAIT (THAT IS, IF THE ENTRY CALL IS ISSUED BY A
+-- "CONDITIONAL_ENTRY_CALL" AND THUS FOLLOWS A NO-WAIT POLICY
+-- (DEMANDING UNCONDITIONALLY THAT "YOU DO IT N O W , OR ELSE"),
+-- WHILE THE CALLEE IS ALSO COMMITTED TO A NO-WAIT POLICY,
+-- BY VIRTUE OF A SELECTIVE_WAIT STATEMENT OF THE THIRD KIND
+-- (WITH AN "ELSE" PART) IN WHICH THE CORRESPONDING ACCEPT_STATEMENT
+-- IS EMBEDDED).
+-- ("CLOSE ENCOUNTERS OF THE THIRD KIND" -- ARE THEY POSSIBLE?)
+
+
+-- THE SEMANTICS OF THIS ENTRY CALL REQUIRES THAT THE CALLING TASK
+-- N O T ENTER ITSELF ON ANY QUEUE BUT RATHER ATTEMPT AN IMMEDIATE
+-- RENDEZVOUS WHICH IS TO TAKE PLACE IF AND ONLY IF THE CALLED TASK
+-- HAS REACHED A POINT WHERE IT IS READY TO ACCEPT THE CALL (I.E.
+-- IT IS EITHER WAITING AT AN ACCEPT STATEMENT FOR THE CORRESPONDING
+-- ENTRY OR IT IS WAITING AT A SELECTIVE_WAIT STATEMENT WITH AN OPEN
+-- ALTERNATIVE STARTING WITH SUCH AN ACCEPT STATEMENT). IT ALSO
+-- REQUIRES THAT THE ENTRY CALL BE CANCELLED IF THE CALLED TASK
+-- IS NOT AT SUCH A POINT. ON THE OTHER HAND, THE SEMANTICS OF THE
+-- SELECTIVE_WAIT STATEMENT WITH AN 'ELSE' PART SPECIFIES THAT
+-- THE 'ELSE' PART MUST BE SELECTED IF NO 'ACCEPT' ALTERNATIVE
+-- CAN BE IMMEDIATELY SELECTED, AND THAT SUCH AN ALTERNATIVE
+-- IS DEEMED TO BE IMMEDIATELY SELECTABLE ("SELECTION OF ONE SUCH
+-- ALTERNATIVE OCCURS IMMEDIATELY"), AND A CORRESPONDING RENDEZVOUS
+-- POSSIBLE, IF AND ONLY IF THERE IS A CORRESPONDING ENTRY CALL
+-- W A I T I N G TO BE ACCCEPTED. A "CONDITIONAL ENTRY CALL"
+-- NEVER WAITS, AND IS NEVER ENTERED IN WAIT QUEUES; IT TAKES
+-- THE 'ELSE' PART INSTEAD.
+
+
+-- NOTE: IF THIS TEST PROGRAM HANGS UP, THE COMPILER WILL BE DEEMED
+-- TO HAVE FAILED.
+
+
+-- RM 3/19/82
+
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97201X IS
+
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ;
+
+ CALLER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ;
+ SERVER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ;
+ QUEUE_NOT_EMPTY : BOOLEAN := FALSE ;
+
+BEGIN
+
+
+ TEST ("C97201X", "CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF" &
+ " BOTH PARTNERS REFUSE TO WAIT" );
+
+
+ DECLARE
+
+
+ TASK T IS
+ ENTRY SYNCHRONIZE ;
+ ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN);
+ ENTRY KEEP_ALIVE ;
+ END T ;
+
+
+ TASK BODY T IS
+ BEGIN
+
+
+ ACCEPT SYNCHRONIZE ;
+
+
+ IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN
+ QUEUE_NOT_EMPTY := TRUE ;
+ END IF;
+
+
+ SELECT
+ ACCEPT DO_IT_NOW_ORELSE
+ ( DID_YOU_DO_IT : IN OUT BOOLEAN )
+ DO
+ DID_YOU_DO_IT := TRUE ;
+ END ;
+ ELSE -- (I.E. TASK ADOPTS NO-WAIT POLICY)
+ -- 'ELSE' BRANCH MUST THEREFORE BE CHOSEN
+ SERVER_TAKES_WRONG_BRANCH := FALSE ;
+ END SELECT;
+
+
+ IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN
+ QUEUE_NOT_EMPTY := TRUE ;
+ END IF;
+
+
+ ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM
+ -- TERMINATING IF IT GETS TO
+ -- THE NO-WAIT MEETING-PLACE
+ -- AHEAD OF THE CALLER (WHICH
+ -- WOULD LEAD TO A SUBSEQUENT
+ -- TASKING_ERROR AT THE TIME OF
+ -- THE NO-WAIT CALL).
+
+
+ END T ;
+
+
+ BEGIN
+
+
+ T.SYNCHRONIZE ; -- TO MINIMIZE THE N E E D TO WAIT
+
+
+ SELECT
+ T.DO_IT_NOW_ORELSE ( RENDEZVOUS_OCCURRED );
+ ELSE -- (I.E. CALLER TOO ADOPTS A NO-WAIT POLICY)
+ -- MUST THEREFORE CHOOSE THIS BRANCH
+ CALLER_TAKES_WRONG_BRANCH := FALSE ;
+ END SELECT;
+
+
+ T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS
+
+
+ END; -- END OF BLOCK CONTAINING THE NO-WAIT ENTRY CALL
+
+
+ IF RENDEZVOUS_OCCURRED
+ THEN
+ FAILED( "RENDEZVOUS OCCURRED" );
+ END IF;
+
+ IF CALLER_TAKES_WRONG_BRANCH OR
+ SERVER_TAKES_WRONG_BRANCH
+ THEN
+ FAILED( "WRONG BRANCH TAKEN" );
+ END IF;
+
+ IF QUEUE_NOT_EMPTY
+ THEN
+ FAILED( "ENTRY QUEUE NOT EMPTY" );
+ END IF;
+
+
+ RESULT;
+
+
+END C97201X ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97202a.ada b/gcc/testsuite/ada/acats/tests/c9/c97202a.ada
new file mode 100644
index 000000000..3856e7fd2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97202a.ada
@@ -0,0 +1,100 @@
+-- C97202A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE INDEX IS EVALUATED BEFORE THE ENTRY PARAMETER AND BOTH
+-- THE INDEX AND THE ENTRY PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS
+-- IS ATTEMPED.
+
+-- RM 4/05/82
+-- TBN 2/3/86 ADDED A CHECK THAT INDEX IS EVALUATED BEFORE THE ENTRY
+-- PARAMETER AND FIXED APPROPRIATE COMMENTS.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97202A IS
+
+ INDEX_COMPUTED : BOOLEAN := FALSE ;
+ FORMAL_COMPUTED : BOOLEAN := FALSE ;
+
+BEGIN
+
+ TEST ("C97202A", "CHECK THAT THE INDEX IS EVALUATED BEFORE THE " &
+ "ENTRY PARAMETER AND BOTH INDEX AND THE ENTRY " &
+ "PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS " &
+ "IS ATTEMPTED");
+
+ DECLARE
+ SUBTYPE SHORT IS INTEGER RANGE 10..20 ;
+
+ TASK T IS
+ ENTRY DO_IT_NOW_ORELSE (SHORT)
+ (DID_YOU_DO_IT : IN BOOLEAN);
+ ENTRY KEEP_ALIVE ;
+ END T ;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT KEEP_ALIVE ;
+ END T ;
+
+ FUNCTION F1 (X:INTEGER) RETURN INTEGER IS
+ BEGIN
+ IF FORMAL_COMPUTED THEN
+ FAILED ("INDEX WAS NOT EVALUATED FIRST");
+ END IF;
+ INDEX_COMPUTED := TRUE ;
+ RETURN (7) ;
+ END F1 ;
+
+ FUNCTION F2 (X:INTEGER) RETURN BOOLEAN IS
+ BEGIN
+ FORMAL_COMPUTED := TRUE ;
+ RETURN (FALSE) ;
+ END F2 ;
+
+ BEGIN
+ SELECT
+ T.DO_IT_NOW_ORELSE ( 6 + F1(7) )
+ ( NOT(F2(7)) ) ;
+ ELSE
+ NULL ;
+ END SELECT;
+
+ T.KEEP_ALIVE ;
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALLS.
+
+ IF INDEX_COMPUTED THEN
+ NULL ;
+ ELSE
+ FAILED( "ENTRY INDEX WAS NOT COMPUTED" );
+ END IF;
+
+ IF FORMAL_COMPUTED THEN
+ NULL ;
+ ELSE
+ FAILED( "ENTRY PARAMETER WAS NOT COMPUTED" );
+ END IF;
+
+ RESULT;
+
+END C97202A ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203a.ada b/gcc/testsuite/ada/acats/tests/c9/c97203a.ada
new file mode 100644
index 000000000..64510dd9e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97203a.ada
@@ -0,0 +1,125 @@
+-- C97203A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A
+-- SELECTIVE_WAIT CANNOT.
+
+-- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY.
+
+
+-- RM 4/01/1982
+
+
+WITH REPORT;
+USE REPORT;
+PROCEDURE C97203A IS
+
+
+BEGIN
+
+
+ TEST ( "C97203A" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" &
+ " APPEAR WHERE A SELECTIVE_WAIT CANNOT" );
+
+
+ -------------------------------------------------------------------
+
+
+ DECLARE
+
+
+ TASK TT IS
+ ENTRY A ( AUTHORIZED : IN BOOLEAN );
+ END TT ;
+
+
+ TASK BODY TT IS
+
+
+ PACKAGE WITHIN_TASK_BODY IS
+ -- NOTHING HERE
+ END WITHIN_TASK_BODY ;
+
+
+ PACKAGE BODY WITHIN_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ A ( FALSE ) ; -- CALLING (OWN) ENTRY
+ ELSE
+ COMMENT( "ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END WITHIN_TASK_BODY ;
+
+
+ BEGIN
+
+ ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO
+
+ IF AUTHORIZED THEN
+ COMMENT( "AUTHORIZED ENTRY_CALL" );
+ ELSE
+ FAILED( "UNAUTHORIZED ENTRY_CALL" );
+ END IF;
+
+ END A ;
+
+ END TT ;
+
+
+ PACKAGE OUTSIDE_TASK_BODY IS
+ -- NOTHING HERE
+ END OUTSIDE_TASK_BODY ;
+
+
+ PACKAGE BODY OUTSIDE_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ TT.A ( FALSE ) ; -- UNBORN
+ ELSE
+ COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END OUTSIDE_TASK_BODY ;
+
+
+ BEGIN
+
+ TT.A ( TRUE );
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ FAILED( "TASKING ERROR" );
+
+ END ;
+
+ -------------------------------------------------------------------
+
+ RESULT ;
+
+
+END C97203A ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203b.ada b/gcc/testsuite/ada/acats/tests/c9/c97203b.ada
new file mode 100644
index 000000000..089815495
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97203b.ada
@@ -0,0 +1,131 @@
+-- C97203B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A
+-- SELECTIVE_WAIT CANNOT.
+
+-- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY.
+
+
+-- RM 4/09/1982
+
+
+WITH REPORT;
+USE REPORT;
+PROCEDURE C97203B IS
+
+
+BEGIN
+
+
+ TEST ( "C97203B" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" &
+ " APPEAR WHERE A SELECTIVE_WAIT CANNOT" );
+
+
+ -------------------------------------------------------------------
+
+
+ DECLARE
+
+
+ TASK TT IS
+ ENTRY A ( AUTHORIZED : IN BOOLEAN );
+ END TT ;
+
+
+ TASK BODY TT IS
+
+
+ PROCEDURE WITHIN_TASK_BODY ;
+
+
+ PROCEDURE WITHIN_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ A ( FALSE ) ; -- CALLING (OWN) ENTRY
+ ELSE
+ COMMENT( "ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END WITHIN_TASK_BODY ;
+
+
+ BEGIN
+
+
+ -- CALL THE INNER PROC. TO FORCE EXEC. OF COND_E_CALL
+ WITHIN_TASK_BODY ;
+
+
+ ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO
+
+ IF AUTHORIZED THEN
+ COMMENT( "AUTHORIZED ENTRY_CALL" );
+ ELSE
+ FAILED( "UNAUTHORIZED ENTRY_CALL" );
+ END IF;
+
+ END A ;
+
+ END TT ;
+
+
+ PROCEDURE OUTSIDE_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ TT.A ( FALSE ) ; -- UNBORN
+ ELSE
+ COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END OUTSIDE_TASK_BODY ;
+
+
+ PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END;
+ PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS
+ BEGIN
+ -- CALL THE OTHER PROC. TO FORCE EXEC. OF COND_E_CALL
+ OUTSIDE_TASK_BODY ;
+ END CREATE_OPPORTUNITY_TO_CALL ;
+
+
+ BEGIN
+
+ TT.A ( TRUE );
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ FAILED( "TASKING ERROR" );
+
+ END ;
+
+ -------------------------------------------------------------------
+
+ RESULT ;
+
+
+END C97203B ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203c.ada b/gcc/testsuite/ada/acats/tests/c9/c97203c.ada
new file mode 100644
index 000000000..d8d9bf5a8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97203c.ada
@@ -0,0 +1,124 @@
+-- C97203C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A CONDITIONAL ENTRY CALL CAN APPEAR IN PLACES WHERE A
+-- SELECTIVE WAIT IS NOT ALLOWED.
+
+-- PART 3: TASK BODY NESTED WITHIN A TASK.
+
+-- WRG 7/15/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97203C IS
+
+BEGIN
+
+ TEST ("C97203C", "CHECK THAT A CONDITIONAL ENTRY CALL CAN " &
+ "APPEAR IN PLACES WHERE A SELECTIVE WAIT " &
+ "IS NOT ALLOWED; CASE: TASK BODY NESTED " &
+ "WITHIN A TASK");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ ENTRY SYNCH;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT SYNCH;
+ ACCEPT SYNCH;
+ ACCEPT SYNCH;
+ ACCEPT E;
+ END T;
+
+ TASK OUTER IS
+ ENTRY E;
+ ENTRY SYNCH;
+ END OUTER;
+
+ TASK BODY OUTER IS
+
+ TASK TYPE INNER;
+
+ INNER1 : INNER;
+
+ TASK BODY INNER IS
+ BEGIN
+ SELECT
+ T.E;
+ FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " &
+ "INNER (1)");
+ ELSE
+ T.SYNCH;
+ END SELECT;
+
+ SELECT
+ OUTER.E;
+ FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " &
+ "INNER (2)");
+ ELSE
+ OUTER.SYNCH;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - INNER");
+ END INNER;
+
+ PACKAGE DUMMY IS
+ TYPE ACC_INNER IS ACCESS INNER;
+ INNER2 : ACC_INNER := NEW INNER;
+ END DUMMY;
+
+ BEGIN
+
+ SELECT
+ T.E;
+ FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - OUTER");
+ ELSE
+ T.SYNCH;
+ END SELECT;
+
+ ACCEPT SYNCH;
+ ACCEPT SYNCH;
+ ACCEPT E;
+
+ EXCEPTION
+
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - OUTER");
+
+ END OUTER;
+
+ BEGIN
+
+ T.E;
+ OUTER.E;
+
+ END;
+
+ RESULT;
+
+END C97203C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97204a.ada b/gcc/testsuite/ada/acats/tests/c9/c97204a.ada
new file mode 100644
index 000000000..a1913a0b3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97204a.ada
@@ -0,0 +1,122 @@
+-- C97204A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED
+-- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE
+-- CONDITIONAL_ENTRY_CALL.
+
+
+-- RM 5/28/82
+-- SPS 11/21/82
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97204A IS
+
+ -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST )
+
+BEGIN
+
+
+ -------------------------------------------------------------------
+
+
+ TEST ("C97204A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" &
+ " BE RAISED IF THE CALLED TASK HAS ALREADY" &
+ " COMPLETED ITS EXECUTION AT THE TIME OF THE" &
+ " CONDITIONAL_ENTRY_CALL" );
+
+
+ DECLARE
+
+
+ TASK TYPE T_TYPE IS
+
+
+ ENTRY E ;
+
+ END T_TYPE ;
+
+
+ T_OBJECT1 : T_TYPE ;
+
+
+ TASK BODY T_TYPE IS
+ BUSY : BOOLEAN := FALSE ;
+ BEGIN
+
+ NULL;
+
+ END T_TYPE ;
+
+
+ BEGIN
+
+
+ FOR I IN 1..5 LOOP
+ EXIT WHEN T_OBJECT1'TERMINATED ;
+ DELAY 10.0 * Impdef.One_Second;
+ END LOOP;
+
+
+ IF NOT T_OBJECT1'TERMINATED THEN
+ COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" );
+ END IF;
+
+
+ BEGIN
+
+ SELECT
+ T_OBJECT1.E ;
+ FAILED( "CALL WAS NOT DISOBEYED" );
+ ELSE
+ FAILED( "'ELSE' BRANCH TAKEN INSTEAD OF TSKG_ERR" );
+ END SELECT;
+
+ FAILED( "EXCEPTION NOT RAISED" );
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ NULL ;
+
+ WHEN OTHERS =>
+ FAILED( "WRONG EXCEPTION RAISED" );
+
+ END ;
+
+
+ END ;
+
+
+ -------------------------------------------------------------------
+
+
+
+ RESULT;
+
+
+END C97204A ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97204b.ada b/gcc/testsuite/ada/acats/tests/c9/c97204b.ada
new file mode 100644
index 000000000..9e52a9deb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97204b.ada
@@ -0,0 +1,82 @@
+-- C97204B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED
+-- BEFORE THE CONDITIONAL ENTRY CALL IS EXECUTED.
+
+-- WRG 7/13/86
+
+WITH REPORT; USE REPORT;
+PROCEDURE C97204B IS
+
+BEGIN
+
+ TEST ("C97204B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " &
+ "CALLED TASK IS ABORTED BEFORE THE CONDITIONAL " &
+ "ENTRY CALL IS EXECUTED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (I : INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (I : INTEGER);
+ FAILED ("ENTRY CALL ACCEPTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED");
+ END T;
+
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ ABORT T;
+ RETURN 1;
+ END F;
+
+ BEGIN
+
+ SELECT
+ T.E (F);
+ FAILED ("CONDITIONAL ENTRY CALL MADE");
+ ELSE
+ FAILED ("ELSE PART EXECUTED");
+ END SELECT;
+
+ FAILED ("EXCEPTION NOT RAISED");
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+
+ END;
+
+ RESULT;
+
+END C97204B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97205a.ada b/gcc/testsuite/ada/acats/tests/c9/c97205a.ada
new file mode 100644
index 000000000..a0bd4d9b2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97205a.ada
@@ -0,0 +1,94 @@
+-- C97205A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A
+-- CONDITIONAL ENTRY CALL), IT IS PERFORMED.
+
+-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT
+-- STATEMENT.
+
+-- WRG 7/13/86
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97205A IS
+
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE;
+ STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE;
+ COUNT : POSITIVE := 1;
+
+
+BEGIN
+
+ TEST ("C97205A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " &
+ "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " &
+ "IS PERFORMED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (B : IN OUT BOOLEAN);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (B : IN OUT BOOLEAN) DO
+ B := IDENT_BOOL (TRUE);
+ END E;
+ END T;
+
+ BEGIN
+
+ WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP
+ DELAY 1.0 * Impdef.One_Second;
+
+ SELECT
+ T.E (RENDEZVOUS_OCCURRED);
+ STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE);
+ ELSE
+ IF COUNT < 60 * 60 THEN
+ COUNT := COUNT + 1;
+ ELSE
+ FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " &
+ "HOUR ELAPSED");
+ EXIT;
+ END IF;
+ END SELECT;
+ END LOOP;
+
+ END;
+
+ IF NOT RENDEZVOUS_OCCURRED THEN
+ FAILED ("RENDEZVOUS DID NOT OCCUR");
+ END IF;
+
+ IF COUNT > 1 THEN
+ COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS");
+ END IF;
+
+ RESULT;
+
+END C97205A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97205b.ada b/gcc/testsuite/ada/acats/tests/c9/c97205b.ada
new file mode 100644
index 000000000..ec49ad577
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97205b.ada
@@ -0,0 +1,98 @@
+-- C97205B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A
+-- CONDITIONAL ENTRY CALL), IT IS PERFORMED.
+
+-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT.
+
+-- WRG 7/13/86
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97205B IS
+
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE;
+ STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE;
+ COUNT : POSITIVE := 1;
+
+
+BEGIN
+
+ TEST ("C97205B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " &
+ "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " &
+ "IS PERFORMED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (1..3) (B : IN OUT BOOLEAN);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E (2) (B : IN OUT BOOLEAN) DO
+ B := IDENT_BOOL (TRUE);
+ END E;
+ OR
+ ACCEPT E (3) (B : IN OUT BOOLEAN);
+ FAILED ("NONEXISTENT ENTRY CALL ACCEPTED");
+ END SELECT;
+ END T;
+
+ BEGIN
+
+ WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP
+ DELAY 1.0 * Impdef.One_Second;
+
+ SELECT
+ T.E (2) (RENDEZVOUS_OCCURRED);
+ STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE);
+ ELSE
+ IF COUNT < 60 * 60 THEN
+ COUNT := COUNT + 1;
+ ELSE
+ FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " &
+ "HOUR ELAPSED");
+ EXIT;
+ END IF;
+ END SELECT;
+ END LOOP;
+
+ END;
+
+ IF NOT RENDEZVOUS_OCCURRED THEN
+ FAILED ("RENDEZVOUS DID NOT OCCUR");
+ END IF;
+
+ IF COUNT > 1 THEN
+ COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS");
+ END IF;
+
+ RESULT;
+
+END C97205B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301a.ada b/gcc/testsuite/ada/acats/tests/c9/c97301a.ada
new file mode 100644
index 000000000..81c65fb11
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97301a.ada
@@ -0,0 +1,158 @@
+-- C97301A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED
+-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE.
+
+-- CASE A: THE TASK TO BE CALLED HAS NOT YET BEEN ACTIVATED AS OF THE
+-- MOMENT OF CALL.
+
+-- RJW 3/31/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97301A IS
+
+ WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second;
+ OR_BRANCH_TAKEN : INTEGER := 3;
+
+BEGIN
+
+ TEST ("C97301A", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " &
+ "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " &
+ "CALLED TASK IS NOT ACTIVE" );
+
+ ------------------------------------------------------------------
+
+ DECLARE
+
+ TASK T IS
+ ENTRY DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN );
+ END T;
+
+ TASK BODY T IS
+
+ PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT;
+ PACKAGE BODY SECOND_ATTEMPT IS
+ START_TIME : TIME;
+ BEGIN
+ START_TIME := CLOCK;
+ SELECT
+ DO_IT_NOW_OR_WAIT (FALSE); --CALLING OWN ENTRY.
+ OR
+ -- THEREFORE THIS BRANCH
+ -- MUST BE CHOSEN.
+ DELAY WAIT_TIME;
+ IF CLOCK >= (WAIT_TIME + START_TIME) THEN
+ NULL;
+ ELSE
+ FAILED ( "INSUFFICIENT DELAY (#2)" );
+ END IF;
+ OR_BRANCH_TAKEN := 2 * OR_BRANCH_TAKEN;
+ COMMENT( "OR_BRANCH TAKEN (#2)" );
+ END SELECT;
+ END SECOND_ATTEMPT;
+
+ BEGIN
+
+ ACCEPT DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN ) DO
+
+ IF AUTHORIZED THEN
+ COMMENT( "AUTHORIZED ENTRY_CALL" );
+ ELSE
+ FAILED( "UNAUTHORIZED ENTRY_CALL" );
+ END IF;
+
+ END DO_IT_NOW_OR_WAIT;
+
+
+ END T;
+
+
+ PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT;
+ PACKAGE BODY FIRST_ATTEMPT IS
+ START_TIME : TIME;
+ BEGIN
+ START_TIME := CLOCK;
+ SELECT
+ T.DO_IT_NOW_OR_WAIT (FALSE);
+ OR
+ -- THIS BRANCH MUST BE CHOSEN.
+ DELAY WAIT_TIME;
+ IF CLOCK >= (WAIT_TIME + START_TIME) THEN
+ NULL;
+ ELSE
+ FAILED ( "INSUFFICIENT DELAY (#1)" );
+ END IF;
+ OR_BRANCH_TAKEN := 1 + OR_BRANCH_TAKEN;
+ COMMENT( "OR_BRANCH TAKEN (#1)" );
+ END SELECT;
+
+ END FIRST_ATTEMPT;
+
+ BEGIN
+
+ T.DO_IT_NOW_OR_WAIT ( TRUE ); -- TO SATISFY THE SERVER'S
+ -- WAIT FOR SUCH A CALL.
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ FAILED( "TASKING ERROR" );
+
+ END ;
+
+
+ ------------------------------------------------------------------
+
+
+ -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED).
+
+
+ CASE OR_BRANCH_TAKEN IS
+
+ WHEN 3 =>
+ FAILED( "NO 'OR'; BOTH (?) RENDEZVOUS ATTEMPTED?" );
+
+ WHEN 4 =>
+ FAILED( "'OR' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" );
+
+ WHEN 6 =>
+ FAILED( "'OR' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" );
+
+ WHEN 7 =>
+ FAILED( "WRONG ORDER FOR 'OR': #2,#1" );
+
+ WHEN 8 =>
+ NULL;
+
+ WHEN OTHERS =>
+ FAILED( "WRONG CASE_VALUE" );
+
+ END CASE;
+
+ RESULT;
+
+END C97301A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301b.ada b/gcc/testsuite/ada/acats/tests/c9/c97301b.ada
new file mode 100644
index 000000000..f6dead392
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97301b.ada
@@ -0,0 +1,147 @@
+-- C97301B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED
+-- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE.
+
+-- CASE B: THE QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS
+-- ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE COMPLETED WITHIN
+-- THE SPECIFIED DELAY.
+
+--HISTORY:
+-- RJW 03/31/86 CREATED ORIGINAL TEST.
+-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97301B IS
+
+ OR_BRANCH_TAKEN : BOOLEAN := FALSE;
+
+BEGIN
+
+ TEST ("C97301B", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " &
+ "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " &
+ "QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS " &
+ "ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE " &
+ "COMPLETED WITHIN THE SPECIFIED DELAY" );
+
+
+ DECLARE
+ WAIT_TIME : DURATION := 3.0 * Impdef.One_Second;
+
+ TASK T1;
+
+ TASK T2 IS
+ ENTRY AWAKEN_T2;
+ END T2;
+
+ TASK T3 IS
+ ENTRY AWAKEN_T3;
+ ENTRY RELEASE_T;
+ END T3;
+
+ TASK T IS
+ ENTRY DO_IT_NOW_OR_WAIT (X : INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO
+ IF X = 1 THEN
+ T2.AWAKEN_T2;
+ WHILE DO_IT_NOW_OR_WAIT'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+ T3.AWAKEN_T3;
+ T3.RELEASE_T;
+ ELSE
+ FAILED ("WRONG TASK IN RENDEZVOUS - 1");
+ END IF;
+ END DO_IT_NOW_OR_WAIT;
+ ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO
+ IF X /= 2 THEN
+ FAILED ("WRONG TASK IN RENDEZVOUS - 2");
+ END IF;
+ END DO_IT_NOW_OR_WAIT;
+ END T;
+
+ TASK BODY T1 IS
+ BEGIN
+ T.DO_IT_NOW_OR_WAIT (1);
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT AWAKEN_T2;
+ T.DO_IT_NOW_OR_WAIT (2);
+ END T2;
+
+ TASK BODY T3 IS
+ START_TIME : TIME;
+ STOP_TIME : TIME;
+ BEGIN
+ BEGIN
+ ACCEPT AWAKEN_T3;
+ START_TIME := CLOCK;
+ SELECT
+ T.DO_IT_NOW_OR_WAIT (3);
+ OR
+ -- THIS BRANCH MUST BE CHOSEN.
+ DELAY WAIT_TIME;
+ STOP_TIME := CLOCK;
+ IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN
+ NULL;
+ ELSE
+ FAILED ( "INSUFFICIENT DELAY" );
+ END IF;
+ OR_BRANCH_TAKEN := TRUE;
+ COMMENT( "OR_BRANCH TAKEN" );
+ ACCEPT RELEASE_T;
+ END SELECT;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ( "TASKING ERROR" );
+ END;
+ -- END OF BLOCK CONTAINING TIMED
+ -- ENTRY CALL.
+
+ -- BY NOW, THE TASK T IS EFFECTIVELY
+ -- TERMINATED (AND THE NONLOCALS UPDATED).
+
+ IF OR_BRANCH_TAKEN THEN
+ NULL;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED" );
+ END IF;
+ END T3;
+ BEGIN
+ NULL;
+ END;
+
+ RESULT;
+
+END C97301B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301c.ada b/gcc/testsuite/ada/acats/tests/c9/c97301c.ada
new file mode 100644
index 000000000..a2b3abbc0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97301c.ada
@@ -0,0 +1,101 @@
+-- C97301C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED
+-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE.
+
+-- CASE C: AN ACCEPT STATEMENT FOR THE CALLED ENTRY HAS NOT BEEN
+-- REACHED.
+
+-- RJW 3/31/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97301C IS
+
+ OR_BRANCH_TAKEN : BOOLEAN := FALSE;
+
+BEGIN
+
+ TEST ("C97301C", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " &
+ "LEAST THE SPECIFIED AMOUNT OF TIME WHEN AN " &
+ "ACCEPT STATEMENT FOR THE CALLED ENTRY HAS " &
+ "NOT BEEN REACHED" );
+
+
+ DECLARE
+ START_TIME : TIME;
+ STOP_TIME : TIME;
+ WAIT_TIME : DURATION := 3.0 * Impdef.One_Second;
+
+ TASK T IS
+ ENTRY NO_SPIN;
+ ENTRY DO_IT_NOW_OR_WAIT;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT NO_SPIN;
+ ACCEPT DO_IT_NOW_OR_WAIT;
+ END T;
+
+ BEGIN
+ START_TIME := CLOCK;
+ SELECT
+ T.DO_IT_NOW_OR_WAIT;
+ FAILED("RENDEZVOUS OCCURRED");
+ ABORT T;
+ OR
+ -- THIS BRANCH MUST BE CHOSEN.
+ DELAY WAIT_TIME;
+ STOP_TIME := CLOCK;
+ IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN
+ NULL;
+ ELSE
+ FAILED ( "INSUFFICIENT DELAY" );
+ END IF;
+ T.NO_SPIN;
+ OR_BRANCH_TAKEN := TRUE;
+ COMMENT( "OR_BRANCH TAKEN" );
+ T.DO_IT_NOW_OR_WAIT;
+ END SELECT;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ( "TASKING ERROR" );
+ END;
+ -- END OF BLOCK CONTAINING TIMED
+ -- ENTRY CALL.
+
+ -- BY NOW, TASK T IS TERMINATED (AND THE NONLOCALS UPDATED).
+
+ IF OR_BRANCH_TAKEN THEN
+ NULL;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED" );
+ END IF;
+
+ RESULT;
+
+END C97301C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301d.ada b/gcc/testsuite/ada/acats/tests/c9/c97301d.ada
new file mode 100644
index 000000000..e473fa772
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97301d.ada
@@ -0,0 +1,106 @@
+-- C97301D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED
+-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE.
+
+-- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY
+-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY.
+
+-- RJW 3/31/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97301D IS
+
+ OR_BRANCH_TAKEN : BOOLEAN := FALSE;
+
+BEGIN
+
+ TEST ("C97301D", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " &
+ "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " &
+ "BODY OF THE TASK CONTAINING THE CALLED ENTRY " &
+ "DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR " &
+ "THAT ENTRY" );
+
+ DECLARE
+ START_TIME : TIME;
+ WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second;
+
+ TASK T IS
+ ENTRY DO_IT_NOW_OR_WAIT;
+ ENTRY KEEP_ALIVE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+
+ -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED.
+
+ ACCEPT KEEP_ALIVE; -- TO PREVENT THIS SERVER TASK FROM
+ -- TERMINATING IF
+ -- UPON ACTIVATION
+ -- IT GETS TO RUN
+ -- AHEAD OF THE CALLER (WHICH
+ -- WOULD LEAD TO A SUBSEQUENT
+ -- TASKING_ERROR AT THE TIME
+ -- OF THE NO-WAIT CALL).
+
+ END;
+
+ BEGIN
+ START_TIME := CLOCK;
+ SELECT
+ T.DO_IT_NOW_OR_WAIT;
+ OR
+ -- THIS BRANCH MUST BE CHOSEN.
+ DELAY WAIT_TIME;
+ IF CLOCK >= (WAIT_TIME + START_TIME) THEN
+ NULL;
+ ELSE
+ FAILED ( "INSUFFICIENT WAITING TIME" );
+ END IF;
+ OR_BRANCH_TAKEN := TRUE;
+ COMMENT( "OR_BRANCH TAKEN" );
+ END SELECT;
+
+ T.KEEP_ALIVE;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ( "TASKING ERROR RAISED" );
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALL.
+
+ -- BY NOW, THE TASK IS TERMINATED.
+
+ IF OR_BRANCH_TAKEN THEN
+ NULL;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED?" );
+ END IF;
+
+ RESULT;
+
+END C97301D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301e.ada b/gcc/testsuite/ada/acats/tests/c9/c97301e.ada
new file mode 100644
index 000000000..39bf159de
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97301e.ada
@@ -0,0 +1,118 @@
+-- C97301E.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED
+-- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE.
+
+-- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY
+-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY -
+-- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS
+-- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.)
+
+-- RJW 3/31/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97301E IS
+
+ OR_BRANCH_TAKEN : BOOLEAN := FALSE;
+
+BEGIN
+
+ TEST ("C97301E", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " &
+ "LEAST THE SPECIFIED AMOUNT OF TIME " &
+ "IN THE ABSENCE OF A CORRESPONDING " &
+ "ACCEPT_STATEMENT " );
+
+ DECLARE
+
+ WAIT_TIME : DURATION := 3.0 * Impdef.One_Second;
+
+ START_TIME : TIME;
+
+ STOP_TIME : TIME;
+
+ SUBTYPE SHORT IS INTEGER RANGE 10..20 ;
+
+ KEEP_ALIVE : INTEGER := 15 ;
+
+ TASK T IS
+ ENTRY DO_IT_NOW_OR_WAIT ( SHORT ) ;
+ END T ;
+
+ TASK BODY T IS
+ BEGIN
+
+ -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED.
+ ACCEPT DO_IT_NOW_OR_WAIT ( IDENT_INT(15) );
+
+ -- THIS ALSO PREVENTS THIS SERVER
+ -- TASK FROM TERMINATING IF
+ -- UPON ACTIVATION
+ -- IT GETS TO RUN
+ -- AHEAD OF THE CALLER (WHICH
+ -- WOULD LEAD TO A SUBSEQUENT
+ -- TASKING_ERROR AT THE TIME
+ -- OF THE NO-WAIT CALL).
+
+ END ;
+
+
+ BEGIN
+ START_TIME := CLOCK;
+ SELECT
+ T.DO_IT_NOW_OR_WAIT (10) ; -- ACCEPT_STATEMENT HAS 15.
+ OR
+ -- THEREFORE THIS BRANCH MUST BE CHOSEN.
+ DELAY WAIT_TIME;
+ STOP_TIME := CLOCK;
+ IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN
+ NULL;
+ ELSE
+ FAILED ( "INSUFFICIENT DELAY" );
+ END IF;
+ OR_BRANCH_TAKEN := TRUE ;
+ COMMENT( "OR_BRANCH TAKEN" );
+ END SELECT;
+
+ T.DO_IT_NOW_OR_WAIT (KEEP_ALIVE) ;
+
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ( "TASKING ERROR" );
+
+ END; -- END OF BLOCK CONTAINING THE TIMED ENTRY CALL.
+
+ -- BY NOW, TASK T IS TERMINATED.
+
+ IF OR_BRANCH_TAKEN THEN
+ NULL ;
+ ELSE
+ FAILED( "RENDEZVOUS ATTEMPTED" );
+ END IF;
+
+ RESULT;
+
+END C97301E ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97302a.ada b/gcc/testsuite/ada/acats/tests/c9/c97302a.ada
new file mode 100644
index 000000000..18c7afbd3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97302a.ada
@@ -0,0 +1,116 @@
+-- C97302A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT WHENEVER AN INDEX IS PRESENT IN A TIMED_ENTRY_CALL, IT
+-- IS EVALUATED BEFORE ANY PARAMETER ASSOCIATIONS ARE EVALUATED, AND
+-- PARAMETER ASSOCIATIONS ARE EVALUATED BEFORE THE DELAY EXPRESSION.
+-- THEN A RENDEZVOUS IS ATTEMPTED.
+
+-- RJW 3/31/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH CALENDAR; USE CALENDAR;
+PROCEDURE C97302A IS
+
+ INDEX_COMPUTED : BOOLEAN := FALSE;
+ PARAM_COMPUTED : BOOLEAN := FALSE;
+ DELAY_COMPUTED : BOOLEAN := FALSE;
+BEGIN
+
+ TEST ("C97302A", "CHECK THAT WHENEVER AN INDEX IS PRESENT IN " &
+ "A TIMED_ENTRY_CALL, IT IS EVALUATED BEFORE " &
+ "ANY PARAMETER ASSOCIATIONS ARE EVALUATED, " &
+ "AND PARAMETER ASSOCIATIONS ARE EVALUATED " &
+ "BEFORE THE DELAY EXPRESSION" );
+ DECLARE
+
+ WAIT_TIME : DURATION := 3.0 * Impdef.One_Second;
+
+ TYPE SHORT IS RANGE 10 .. 20;
+
+ TASK T IS
+ ENTRY DO_IT_NOW_OR_WAIT
+ ( SHORT )
+ ( DID_YOU_DO_IT : IN BOOLEAN );
+ ENTRY KEEP_ALIVE;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT KEEP_ALIVE;
+ END T;
+
+ FUNCTION F1 (X : SHORT) RETURN SHORT IS
+ BEGIN
+ INDEX_COMPUTED := TRUE;
+ RETURN (15);
+ END F1;
+
+ FUNCTION F2 RETURN BOOLEAN IS
+ BEGIN
+ IF INDEX_COMPUTED THEN
+ NULL;
+ ELSE
+ FAILED ( "INDEX NOT EVALUATED FIRST" );
+ END IF;
+ PARAM_COMPUTED := TRUE;
+ RETURN (FALSE);
+ END F2;
+
+ FUNCTION F3 RETURN DURATION IS
+ BEGIN
+ IF PARAM_COMPUTED THEN
+ NULL;
+ ELSE
+ FAILED ( "PARAMETERS NOT EVALUATED BEFORE DELAY " &
+ "EXPRESSION" );
+ END IF;
+ DELAY_COMPUTED := TRUE;
+ RETURN (WAIT_TIME);
+ END;
+ BEGIN
+
+ SELECT
+ T.DO_IT_NOW_OR_WAIT
+ ( F1 (15) )
+ ( NOT F2 );
+ FAILED ("RENDEZVOUS OCCURRED");
+ OR
+ DELAY F3;
+ END SELECT;
+
+ T.KEEP_ALIVE;
+
+ END; -- END OF BLOCK CONTAINING THE ENTRY CALLS.
+
+ IF DELAY_COMPUTED THEN
+ NULL;
+ ELSE
+ FAILED( "DELAY EXPRESSION NOT EVALUATED" );
+ END IF;
+
+ RESULT;
+
+END C97302A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303a.ada b/gcc/testsuite/ada/acats/tests/c9/c97303a.ada
new file mode 100644
index 000000000..67504fcf5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97303a.ada
@@ -0,0 +1,128 @@
+-- C97303A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A
+-- SELECTIVE_WAIT CANNOT.
+
+-- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY.
+
+
+-- RM 4/06/1982
+
+with Impdef;
+WITH REPORT;
+USE REPORT;
+PROCEDURE C97303A IS
+
+
+BEGIN
+
+
+ TEST ( "C97303A" , "CHECK THAT A TIMED_ENTRY_CALL CAN" &
+ " APPEAR WHERE A SELECTIVE_WAIT CANNOT" );
+
+
+ -------------------------------------------------------------------
+
+
+ DECLARE
+
+
+ TASK TT IS
+ ENTRY A ( AUTHORIZED : IN BOOLEAN );
+ END TT ;
+
+
+ TASK BODY TT IS
+
+ PACKAGE WITHIN_TASK_BODY IS
+ -- NOTHING HERE
+ END WITHIN_TASK_BODY ;
+
+
+ PACKAGE BODY WITHIN_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ A ( FALSE ) ; -- CALLING (OWN) ENTRY
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ COMMENT( "ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END WITHIN_TASK_BODY ;
+
+
+ BEGIN
+
+ ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO
+
+ IF AUTHORIZED THEN
+ COMMENT( "AUTHORIZED ENTRY_CALL" );
+ ELSE
+ FAILED( "UNAUTHORIZED ENTRY_CALL" );
+ END IF;
+
+ END A ;
+
+ END TT ;
+
+
+ PACKAGE OUTSIDE_TASK_BODY IS
+ -- NOTHING HERE
+ END OUTSIDE_TASK_BODY ;
+
+
+ PACKAGE BODY OUTSIDE_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ TT.A ( FALSE ) ; -- UNBORN
+ OR
+ DELAY 2.0 * Impdef.One_Second;
+ COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END OUTSIDE_TASK_BODY ;
+
+
+ BEGIN
+
+ TT.A ( TRUE );
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ FAILED( "TASKING ERROR" );
+
+ END ;
+
+
+ -------------------------------------------------------------------
+
+
+ RESULT ;
+
+
+END C97303A ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303b.ada b/gcc/testsuite/ada/acats/tests/c9/c97303b.ada
new file mode 100644
index 000000000..5043fa1db
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97303b.ada
@@ -0,0 +1,133 @@
+-- C97303B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A
+-- SELECTIVE_WAIT CANNOT.
+
+-- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY.
+
+
+-- RM 4/12/1982
+
+with Impdef;
+WITH REPORT;
+USE REPORT;
+PROCEDURE C97303B IS
+
+
+BEGIN
+
+
+ TEST ( "C97303B" , "CHECK THAT A TIMED_ENTRY_CALL CAN" &
+ " APPEAR WHERE A SELECTIVE_WAIT CANNOT" );
+
+
+ -------------------------------------------------------------------
+
+
+ DECLARE
+
+
+ TASK TT IS
+ ENTRY A ( AUTHORIZED : IN BOOLEAN );
+ END TT ;
+
+
+ TASK BODY TT IS
+
+
+ PROCEDURE WITHIN_TASK_BODY ;
+
+
+ PROCEDURE WITHIN_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ A ( FALSE ) ; -- CALLING (OWN) ENTRY
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ COMMENT( "ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END WITHIN_TASK_BODY ;
+
+
+ BEGIN
+
+
+ -- CALL THE INNER PROC. TO FORCE EXEC. OF TIMED_E_CALL
+ WITHIN_TASK_BODY ;
+
+
+ ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO
+
+ IF AUTHORIZED THEN
+ COMMENT( "AUTHORIZED ENTRY_CALL" );
+ ELSE
+ FAILED( "UNAUTHORIZED ENTRY_CALL" );
+ END IF;
+
+ END A ;
+
+ END TT ;
+
+
+ PROCEDURE OUTSIDE_TASK_BODY IS
+ BEGIN
+
+ SELECT -- NOT A SELECTIVE_WAIT
+ TT.A ( FALSE ) ; -- UNBORN
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" );
+ END SELECT;
+
+ END OUTSIDE_TASK_BODY ;
+
+
+ PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END;
+ PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS
+ BEGIN
+ -- CALL THE OTHER PROC. TO FORCE EXEC. OF TIMED_E_CALL
+ OUTSIDE_TASK_BODY ;
+ END CREATE_OPPORTUNITY_TO_CALL ;
+
+
+ BEGIN
+
+ TT.A ( TRUE );
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ FAILED( "TASKING ERROR" );
+
+ END ;
+
+ -------------------------------------------------------------------
+
+ RESULT ;
+
+
+END C97303B ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303c.ada b/gcc/testsuite/ada/acats/tests/c9/c97303c.ada
new file mode 100644
index 000000000..a6143037c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97303c.ada
@@ -0,0 +1,128 @@
+-- C97303C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED ENTRY CALL CAN APPEAR IN PLACES WHERE A SELECTIVE
+-- WAIT IS NOT ALLOWED.
+
+-- PART 3: TASK BODY NESTED WITHIN A TASK.
+
+-- WRG 7/15/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97303C IS
+
+BEGIN
+
+ TEST ("C97303C", "CHECK THAT A TIMED ENTRY CALL CAN " &
+ "APPEAR IN PLACES WHERE A SELECTIVE WAIT " &
+ "IS NOT ALLOWED; CASE: TASK BODY NESTED " &
+ "WITHIN A TASK");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E;
+ ENTRY SYNCH;
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT SYNCH;
+ ACCEPT SYNCH;
+ ACCEPT SYNCH;
+ ACCEPT E;
+ END T;
+
+ TASK OUTER IS
+ ENTRY E;
+ ENTRY SYNCH;
+ END OUTER;
+
+ TASK BODY OUTER IS
+
+ TASK TYPE INNER;
+
+ INNER1 : INNER;
+
+ TASK BODY INNER IS
+ BEGIN
+ SELECT
+ T.E;
+ FAILED ("TIMED ENTRY CALL ACCEPTED - " &
+ "INNER (1)");
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ T.SYNCH;
+ END SELECT;
+
+ SELECT
+ OUTER.E;
+ FAILED ("TIMED ENTRY CALL ACCEPTED - " &
+ "INNER (2)");
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ OUTER.SYNCH;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - INNER");
+ END INNER;
+
+ PACKAGE DUMMY IS
+ TYPE ACC_INNER IS ACCESS INNER;
+ INNER2 : ACC_INNER := NEW INNER;
+ END DUMMY;
+
+ BEGIN
+
+ SELECT
+ T.E;
+ FAILED ("TIMED ENTRY CALL ACCEPTED - OUTER");
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ T.SYNCH;
+ END SELECT;
+
+ ACCEPT SYNCH;
+ ACCEPT SYNCH;
+ ACCEPT E;
+
+ EXCEPTION
+
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - OUTER");
+
+ END OUTER;
+
+ BEGIN
+
+ T.E;
+ OUTER.E;
+
+ END;
+
+ RESULT;
+
+END C97303C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97304a.ada b/gcc/testsuite/ada/acats/tests/c9/c97304a.ada
new file mode 100644
index 000000000..8e4504730
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97304a.ada
@@ -0,0 +1,123 @@
+-- C97304A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED
+-- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE
+-- TIMED_ENTRY_CALL.
+
+
+-- RM 5/28/82
+-- SPS 11/21/82
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97304A IS
+
+ -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST )
+
+BEGIN
+
+
+ -------------------------------------------------------------------
+
+
+ TEST ("C97304A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" &
+ " BE RAISED IF THE CALLED TASK HAS ALREADY" &
+ " COMPLETED ITS EXECUTION AT THE TIME OF THE" &
+ " TIMED_ENTRY_CALL" );
+
+
+ DECLARE
+
+
+ TASK TYPE T_TYPE IS
+
+
+ ENTRY E ;
+
+ END T_TYPE ;
+
+
+ T_OBJECT1 : T_TYPE ;
+
+
+ TASK BODY T_TYPE IS
+ BUSY : BOOLEAN := FALSE ;
+ BEGIN
+
+ NULL;
+
+ END T_TYPE ;
+
+
+ BEGIN
+
+
+ FOR I IN 1..5 LOOP
+ EXIT WHEN T_OBJECT1'TERMINATED ;
+ DELAY 10.0 * Impdef.One_Second;
+ END LOOP;
+
+
+ IF NOT T_OBJECT1'TERMINATED THEN
+ COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" );
+ END IF;
+
+
+ BEGIN
+
+ SELECT
+ T_OBJECT1.E ;
+ FAILED( "CALL WAS NOT DISOBEYED" );
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ FAILED( "'OR' BRANCH TAKEN INSTEAD OF TSKG_ERROR" );
+ END SELECT;
+
+ FAILED( "EXCEPTION NOT RAISED" );
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ NULL ;
+
+ WHEN OTHERS =>
+ FAILED( "WRONG EXCEPTION RAISED" );
+
+ END ;
+
+
+ END ;
+
+
+ -------------------------------------------------------------------
+
+
+
+ RESULT;
+
+
+END C97304A ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97304b.ada b/gcc/testsuite/ada/acats/tests/c9/c97304b.ada
new file mode 100644
index 000000000..1d7f4cd06
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97304b.ada
@@ -0,0 +1,84 @@
+-- C97304B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED
+-- BEFORE THE TIMED ENTRY CALL IS EXECUTED.
+
+-- WRG 7/13/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97304B IS
+
+BEGIN
+
+ TEST ("C97304B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " &
+ "CALLED TASK IS ABORTED BEFORE THE TIMED " &
+ "ENTRY CALL IS EXECUTED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (I : INTEGER);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (I : INTEGER);
+ FAILED ("ENTRY CALL ACCEPTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED");
+ END T;
+
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ ABORT T;
+ RETURN 1;
+ END F;
+
+ BEGIN
+
+ SELECT
+ T.E (F);
+ FAILED ("TIMED ENTRY CALL MADE");
+ OR
+ DELAY 1.0 * Impdef.One_Second;
+ FAILED ("DELAY ALTERNATIVE TAKEN");
+ END SELECT;
+
+ FAILED ("EXCEPTION NOT RAISED");
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+
+ END;
+
+ RESULT;
+
+END C97304B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305a.ada b/gcc/testsuite/ada/acats/tests/c9/c97305a.ada
new file mode 100644
index 000000000..81349b87d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97305a.ada
@@ -0,0 +1,100 @@
+-- C97305A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A
+-- TIMED ENTRY CALL), IT IS PERFORMED.
+
+-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT
+-- STATEMENT.
+
+-- WRG 7/13/86
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97305A IS
+
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE;
+ STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE;
+ COUNT : POSITIVE := 1;
+ ZERO : DURATION := 1.0;
+
+
+BEGIN
+
+ TEST ("C97305A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " &
+ "POSSIBLE (FOR A TIMED ENTRY CALL), IT " &
+ "IS PERFORMED");
+
+ IF EQUAL (3, 3) THEN
+ ZERO := 0.0;
+ END IF;
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (B : IN OUT BOOLEAN);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (B : IN OUT BOOLEAN) DO
+ B := IDENT_BOOL (TRUE);
+ END E;
+ END T;
+
+ BEGIN
+
+ WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP
+ DELAY 1.0 * Impdef.One_Second;
+
+ SELECT
+ T.E (RENDEZVOUS_OCCURRED);
+ STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE);
+ OR
+ DELAY ZERO;
+ IF COUNT < 60 * 60 THEN
+ COUNT := COUNT + 1;
+ ELSE
+ FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " &
+ "HOUR ELAPSED");
+ EXIT;
+ END IF;
+ END SELECT;
+ END LOOP;
+
+ END;
+
+ IF NOT RENDEZVOUS_OCCURRED THEN
+ FAILED ("RENDEZVOUS DID NOT OCCUR");
+ END IF;
+
+ IF COUNT > 1 THEN
+ COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS");
+ END IF;
+
+ RESULT;
+
+END C97305A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305b.ada b/gcc/testsuite/ada/acats/tests/c9/c97305b.ada
new file mode 100644
index 000000000..13a28a39e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97305b.ada
@@ -0,0 +1,104 @@
+-- C97305B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A
+-- TIMED ENTRY CALL), IT IS PERFORMED.
+
+-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT.
+
+-- WRG 7/13/86
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97305B IS
+
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE;
+ STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE;
+ COUNT : POSITIVE := 1;
+ ZERO : DURATION := 1.0;
+
+
+BEGIN
+
+ TEST ("C97305B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " &
+ "POSSIBLE (FOR A TIMED ENTRY CALL), IT " &
+ "IS PERFORMED");
+
+ IF EQUAL (3, 3) THEN
+ ZERO := 0.0;
+ END IF;
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (1..3) (B : IN OUT BOOLEAN);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ SELECT
+ ACCEPT E (2) (B : IN OUT BOOLEAN) DO
+ B := IDENT_BOOL (TRUE);
+ END E;
+ OR
+ ACCEPT E (3) (B : IN OUT BOOLEAN);
+ FAILED ("NONEXISTENT ENTRY CALL ACCEPTED");
+ END SELECT;
+ END T;
+
+ BEGIN
+
+ WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP
+ DELAY 1.0 * Impdef.One_Second;
+
+ SELECT
+ T.E (2) (RENDEZVOUS_OCCURRED);
+ STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE);
+ OR
+ DELAY ZERO;
+ IF COUNT < 60 * 60 THEN
+ COUNT := COUNT + 1;
+ ELSE
+ FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " &
+ "HOUR ELAPSED");
+ EXIT;
+ END IF;
+ END SELECT;
+ END LOOP;
+
+ END;
+
+ IF NOT RENDEZVOUS_OCCURRED THEN
+ FAILED ("RENDEZVOUS DID NOT OCCUR");
+ END IF;
+
+ IF COUNT > 1 THEN
+ COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS");
+ END IF;
+
+ RESULT;
+
+END C97305B;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305c.ada b/gcc/testsuite/ada/acats/tests/c9/c97305c.ada
new file mode 100644
index 000000000..ee9953ba4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97305c.ada
@@ -0,0 +1,90 @@
+-- C97305C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES
+-- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED.
+
+-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT
+-- STATEMENT.
+
+-- WRG 7/13/86
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97305C IS
+
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE;
+ STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE;
+ DELAY_IN_MINUTES : CONSTANT POSITIVE := 30;
+
+
+BEGIN
+
+ TEST ("C97305C", "CHECK THAT IF THE RENDEZVOUS IS NOT " &
+ "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " &
+ "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " &
+ "CALL IS ACCEPTED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (B : IN OUT BOOLEAN);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ DELAY 10.0 * Impdef.One_Long_Second;
+ ACCEPT E (B : IN OUT BOOLEAN) DO
+ B := IDENT_BOOL (TRUE);
+ END E;
+ END T;
+
+ BEGIN
+
+ SELECT
+ T.E (RENDEZVOUS_OCCURRED);
+ STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE);
+ OR
+ DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Long_Second;
+ FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" &
+ POSITIVE'IMAGE(DELAY_IN_MINUTES) &
+ " MINUTES ELAPSED");
+
+ END SELECT;
+
+ END;
+
+ IF NOT RENDEZVOUS_OCCURRED THEN
+ FAILED ("RENDEZVOUS DID NOT OCCUR");
+ END IF;
+
+ IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN
+ FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED");
+ END IF;
+
+ RESULT;
+
+END C97305C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305d.ada b/gcc/testsuite/ada/acats/tests/c9/c97305d.ada
new file mode 100644
index 000000000..022b0adcb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97305d.ada
@@ -0,0 +1,95 @@
+-- C97305D.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES
+-- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED.
+
+-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT.
+
+-- WRG 7/13/86
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C97305D IS
+
+ RENDEZVOUS_OCCURRED : BOOLEAN := FALSE;
+ STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE;
+ DELAY_IN_MINUTES : CONSTANT POSITIVE := 30;
+
+
+BEGIN
+
+ TEST ("C97305D", "CHECK THAT IF THE RENDEZVOUS IS NOT " &
+ "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " &
+ "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " &
+ "CALL IS ACCEPTED");
+
+ DECLARE
+
+ TASK T IS
+ ENTRY E (1..3) (B : IN OUT BOOLEAN);
+ END T;
+
+ TASK BODY T IS
+ BEGIN
+ DELAY 10.0 * Impdef.One_Second;
+
+ SELECT
+ ACCEPT E (2) (B : IN OUT BOOLEAN) DO
+ B := IDENT_BOOL (TRUE);
+ END E;
+ OR
+ ACCEPT E (3) (B : IN OUT BOOLEAN);
+ FAILED ("NONEXISTENT ENTRY CALL ACCEPTED");
+ END SELECT;
+ END T;
+
+ BEGIN
+
+ SELECT
+ T.E (2) (RENDEZVOUS_OCCURRED);
+ STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE);
+ OR
+ DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Second;
+ FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" &
+ POSITIVE'IMAGE(DELAY_IN_MINUTES) &
+ " MINUTES ELAPSED");
+
+ END SELECT;
+
+ END;
+
+ IF NOT RENDEZVOUS_OCCURRED THEN
+ FAILED ("RENDEZVOUS DID NOT OCCUR");
+ END IF;
+
+ IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN
+ FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED");
+ END IF;
+
+ RESULT;
+
+END C97305D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c97307a.ada b/gcc/testsuite/ada/acats/tests/c9/c97307a.ada
new file mode 100644
index 000000000..32d26e6b3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c97307a.ada
@@ -0,0 +1,209 @@
+-- C97307A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TIMED ENTRY CALL THAT IS CANCELED (BECAUSE THE DELAY HAS
+-- EXPIRED) IS REMOVED FROM THE QUEUE OF THE CALLED TASK'S ENTRY.
+
+-- WRG 7/14/86
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C97307A IS
+
+BEGIN
+
+ TEST ("C97307A", "CHECK THAT A TIMED ENTRY CALL THAT IS " &
+ "CANCELED (BECAUSE THE DELAY HAS EXPIRED) IS " &
+ "REMOVED FROM THE QUEUE OF THE CALLED TASK'S " &
+ "ENTRY");
+
+ DECLARE
+
+ DELAY_TIME : CONSTANT DURATION := 2 * 60.0 * Impdef.One_Second;
+
+ TASK EXPIRED IS
+ ENTRY INCREMENT;
+ ENTRY READ (COUNT : OUT NATURAL);
+ END EXPIRED;
+
+ TASK TYPE NON_TIMED_CALLER IS
+ ENTRY NAME (N : NATURAL);
+ END NON_TIMED_CALLER;
+
+ TASK TYPE TIMED_CALLER IS
+ ENTRY NAME (N : NATURAL);
+ END TIMED_CALLER;
+
+ CALLER1 : TIMED_CALLER;
+ CALLER2 : NON_TIMED_CALLER;
+ CALLER3 : TIMED_CALLER;
+ CALLER4 : NON_TIMED_CALLER;
+ CALLER5 : TIMED_CALLER;
+
+ TASK T IS
+ ENTRY E (NAME : NATURAL);
+ END T;
+
+ TASK DISPATCH IS
+ ENTRY READY;
+ END DISPATCH;
+
+ --------------------------------------------------
+
+ TASK BODY EXPIRED IS
+ EXPIRED_CALLS : NATURAL := 0;
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT INCREMENT DO
+ EXPIRED_CALLS := EXPIRED_CALLS + 1;
+ END INCREMENT;
+ OR
+ ACCEPT READ (COUNT : OUT NATURAL) DO
+ COUNT := EXPIRED_CALLS;
+ END READ;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END EXPIRED;
+
+ --------------------------------------------------
+
+ TASK BODY NON_TIMED_CALLER IS
+ MY_NAME : NATURAL;
+ BEGIN
+ ACCEPT NAME (N : NATURAL) DO
+ MY_NAME := N;
+ END NAME;
+
+ T.E (MY_NAME);
+ END NON_TIMED_CALLER;
+
+ --------------------------------------------------
+
+ TASK BODY TIMED_CALLER IS
+ MY_NAME : NATURAL;
+ BEGIN
+ ACCEPT NAME (N : NATURAL) DO
+ MY_NAME := N;
+ END NAME;
+
+ SELECT
+ T.E (MY_NAME);
+ FAILED ("TIMED ENTRY CALL NOT CANCELED FOR CALLER" &
+ NATURAL'IMAGE(MY_NAME));
+ OR
+ DELAY DELAY_TIME;
+ EXPIRED.INCREMENT;
+ END SELECT;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN TIMED_CALLER -- " &
+ "CALLER" & NATURAL'IMAGE(MY_NAME));
+ END TIMED_CALLER;
+
+ --------------------------------------------------
+
+ TASK BODY DISPATCH IS
+ BEGIN
+ CALLER1.NAME (1);
+ ACCEPT READY;
+
+ CALLER2.NAME (2);
+ ACCEPT READY;
+
+ CALLER3.NAME (3);
+ ACCEPT READY;
+
+ CALLER4.NAME (4);
+ ACCEPT READY;
+
+ CALLER5.NAME (5);
+ END DISPATCH;
+
+ --------------------------------------------------
+
+ TASK BODY T IS
+
+ DESIRED_QUEUE_LENGTH : NATURAL := 1;
+ EXPIRED_CALLS : NATURAL;
+
+ ACCEPTED : ARRAY (1..5) OF NATURAL RANGE 0..5
+ := (OTHERS => 0);
+ ACCEPTED_INDEX : NATURAL := 0;
+
+ BEGIN
+ LOOP
+ LOOP
+ EXPIRED.READ (EXPIRED_CALLS);
+ EXIT WHEN E'COUNT >= DESIRED_QUEUE_LENGTH -
+ EXPIRED_CALLS;
+ DELAY 2.0 * Impdef.One_Long_Second;
+ END LOOP;
+ EXIT WHEN DESIRED_QUEUE_LENGTH = 5;
+ DISPATCH.READY;
+ DESIRED_QUEUE_LENGTH := DESIRED_QUEUE_LENGTH + 1;
+ END LOOP;
+
+ -- AT THIS POINT, FIVE TASKS WERE QUEUED.
+ -- LET THE TIMED ENTRY CALLS ISSUED BY CALLER1,
+ -- CALLER3, AND CALLER5 EXPIRE:
+
+ DELAY DELAY_TIME + 10.0 * Impdef.One_Long_Second;
+
+ -- AT THIS POINT, ALL THE TIMED ENTRY CALLS MUST HAVE
+ -- EXPIRED AND BEEN REMOVED FROM THE ENTRY QUEUE FOR E,
+ -- OTHERWISE THE IMPLEMENTATION HAS FAILED THIS TEST.
+
+ WHILE E'COUNT > 0 LOOP
+ ACCEPT E (NAME : NATURAL) DO
+ ACCEPTED_INDEX := ACCEPTED_INDEX + 1;
+ ACCEPTED (ACCEPTED_INDEX) := NAME;
+ END E;
+ END LOOP;
+
+ IF ACCEPTED /= (2, 4, 0, 0, 0) THEN
+ FAILED ("SOME TIMED CALLS NOT REMOVED FROM ENTRY " &
+ "QUEUE");
+ COMMENT ("ORDER ACCEPTED WAS:" &
+ NATURAL'IMAGE (ACCEPTED (1)) & ',' &
+ NATURAL'IMAGE (ACCEPTED (2)) & ',' &
+ NATURAL'IMAGE (ACCEPTED (3)) & ',' &
+ NATURAL'IMAGE (ACCEPTED (4)) & ',' &
+ NATURAL'IMAGE (ACCEPTED (5)) );
+ END IF;
+ END T;
+
+ --------------------------------------------------
+
+ BEGIN
+
+ NULL;
+
+ END;
+
+ RESULT;
+
+END C97307A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974001.a b/gcc/testsuite/ada/acats/tests/c9/c974001.a
new file mode 100644
index 000000000..04ac93e6d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974001.a
@@ -0,0 +1,152 @@
+-- C974001.A
+--
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement
+-- is aborted if it does not complete before the triggering statement
+-- completes, where the triggering statement is a delay_relative
+-- statement and check that the sequence of statements of the triggering
+-- alternative is executed after the abortable part is left.
+--
+-- TEST DESCRIPTION:
+-- Declare a task with an accept statement containing an asynchronous
+-- select with a delay_relative triggering statement. Parameterize
+-- the accept statement with the time to be used in the delay. Simulate a
+-- time-consuming calculation by declaring a procedure containing an
+-- infinite loop. Call this procedure in the abortable part.
+--
+-- The delay will expire before the abortable part completes, at which
+-- time the abortable part is aborted, and the sequence of statements
+-- following the triggering statement is executed.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+with Report;
+with ImpDef;
+
+procedure C974001 is
+
+
+ --========================================================--
+
+ -- Medium length delay
+ Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task;
+
+ Calculation_Canceled : exception;
+
+
+ Count : Integer := 1234;
+
+ procedure Lengthy_Calculation is
+ begin
+ -- Simulate a non-converging calculation.
+ loop -- Infinite loop.
+ Count := (Count + 1) mod 10;
+ delay ImpDef.Minimum_Task_Switch; -- allow other task
+ end loop;
+ end Lengthy_Calculation;
+
+
+ --========================================================--
+
+
+ task type Timed_Calculation is
+ entry Calculation (Time_Limit : in Duration);
+ end Timed_Calculation;
+
+
+ task body Timed_Calculation is
+ --
+ begin
+ loop
+ select
+ accept Calculation (Time_Limit : in Duration) do
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ delay Time_Limit; -- Time_Limit is not up yet, so
+ -- Lengthy_Calculation starts.
+
+ raise Calculation_Canceled; -- This is executed after
+ -- Lengthy_Calculation aborted.
+ then abort
+ Lengthy_Calculation; -- Delay expires before complete,
+ -- so this call is aborted.
+
+ -- Check that the whole of the abortable part is aborted,
+ -- not just the statement in the abortable part that was
+ -- executing at the time
+ Report.Failed ("Abortable part not aborted");
+
+ end select;
+
+ Report.Failed ("Triggering alternative sequence of " &
+ "statements not executed");
+
+ exception -- New Ada 9x: handler within accept
+ when Calculation_Canceled =>
+ if Count = 1234 then
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ end Calculation;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Timed_Calculation task");
+ end Timed_Calculation;
+
+
+ --========================================================--
+
+
+begin -- Main program.
+
+ Report.Test ("C974001", "Asynchronous Select: Trigger is delay_relative" &
+ " which completes before abortable part");
+
+ declare
+ Timed : Timed_Calculation; -- Task.
+ begin
+ Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select
+ -- inside accept block.
+ exception
+ when Calculation_Canceled =>
+ null; -- expected behavior
+ end;
+
+ Report.Result;
+
+end C974001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974002.a b/gcc/testsuite/ada/acats/tests/c9/c974002.a
new file mode 100644
index 000000000..1138e8da3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974002.a
@@ -0,0 +1,209 @@
+-- C974002.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the sequence of statements of the triggering alternative
+-- of an asynchronous select statement is executed if the triggering
+-- statement is a delay_until statement, and the specified time has
+-- already passed. Check that the abortable part is not executed after
+-- the sequence of statements of the triggering alternative is left.
+--
+-- Check that the sequence of statements of the triggering alternative
+-- of an asynchronous select statement is not executed if the abortable
+-- part completes before the triggering statement, and the triggering
+-- statement is a delay_until statement.
+--
+-- TEST DESCRIPTION:
+-- Declare a task with an accept statement containing an asynchronous
+-- select with a delay_until triggering statement. Parameterize
+-- the accept statement with the time to be used in the delay. Simulate
+-- a quick calculation by declaring a procedure which sets a Boolean
+-- flag. Call this procedure in the abortable part.
+--
+-- Make two calls to the task entry: (1) with a time that has already
+-- expired, and (2) with a time that will not expire before the quick
+-- calculation completes.
+--
+-- For (1), the sequence of statements following the triggering statement
+-- is executed, and the abortable part never starts.
+--
+-- For (2), the abortable part completes before the triggering statement,
+-- the delay is canceled, and the sequence of statements following the
+-- triggering statement never starts.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 26 Nov 95 SAIC Bug fix for ACVC 2.0.1.
+--
+--!
+
+with Report;
+with Ada.Calendar;
+with ImpDef;
+procedure C974002 is
+
+ function "-" (Left: Ada.Calendar.Time; Right: Duration )
+ return Ada.Calendar.Time renames Ada.Calendar."-";
+ function "+" (Left: Ada.Calendar.Time; Right: Duration )
+ return Ada.Calendar.Time renames Ada.Calendar."+";
+
+ Abortable_Part_Executed : Boolean;
+ Triggering_Alternative_Executed : Boolean;
+
+
+ --========================================================--
+
+
+ procedure Quick_Calculation is
+ begin
+ if Report.Equal (1, 1) then
+ Abortable_Part_Executed := True;
+ end if;
+ end Quick_Calculation;
+
+
+ --========================================================--
+
+
+ task type Timed_Calculation_Task is
+ entry Calculation (Time_Out : in Ada.Calendar.Time);
+ end Timed_Calculation_Task;
+
+
+ task body Timed_Calculation_Task is
+ begin
+ loop
+ select
+ accept Calculation (Time_Out : in Ada.Calendar.Time) do
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ delay until Time_Out; -- Triggering
+ -- statement.
+
+ Triggering_Alternative_Executed := True; -- Triggering
+ -- alternative.
+ then abort
+ Quick_Calculation; -- Abortable part.
+ end select;
+ end Calculation;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Timed_Calculation_Task");
+ end Timed_Calculation_Task;
+
+
+ --========================================================--
+
+
+ Start_Time : constant Ada.Calendar.Time :=
+ Ada.Calendar.Time_of (1901,1,1);
+ Minute : constant Duration := 60.0;
+
+
+ --========================================================--
+
+
+begin -- Main program.
+
+ Report.Test ("C974002", "Asynchronous Select with Delay_Until");
+
+ -- take care of implementations that start the clock at 1/1/01
+ delay ImpDef.Delay_For_Time_Past;
+
+
+ Abortable_Part_Executed := False;
+ Triggering_Alternative_Executed := False;
+
+ NO_DELAY_SUBTEST:
+
+ declare
+ -- Set Expiry to a time which has already passed
+ Expiry : constant Ada.Calendar.Time := Start_Time;
+ Timed : Timed_Calculation_Task;
+ begin
+
+ -- Expiry is the time to be specified in the delay_until statement
+ -- of the asynchronous select. Since it has already passed, the
+ -- abortable part should not execute, and the sequence of statements
+ -- of the triggering alternative should be executed.
+
+ Timed.Calculation (Time_Out => Expiry); -- Asynchronous select
+ -- inside accept block.
+ if Abortable_Part_Executed then
+ Report.Failed ("No delay: Abortable part was executed");
+ end if;
+
+ if not Triggering_Alternative_Executed then
+ Report.Failed ("No delay: triggering alternative sequence " &
+ "of statements was not executed");
+ end if;
+ end No_Delay_Subtest;
+
+
+ Abortable_Part_Executed := False;
+ Triggering_Alternative_Executed := False;
+
+ LONG_DELAY_SUBTEST:
+
+ declare
+
+ -- Quick_Calculation should finish before expiry.
+ Expiry : constant Ada.Calendar.Time :=
+ Ada.Calendar.Clock + Minute;
+ Timed : Timed_Calculation_Task;
+
+ begin
+
+ -- Expiry is the time to be specified in the delay_until statement
+ -- of the asynchronous select. It should not pass before the abortable
+ -- part completes, at which time control should return to the caller;
+ -- the sequence of statements of the triggering alternative should
+ -- not be executed.
+
+ Timed.Calculation (Time_Out => Expiry); -- Asynchronous select.
+
+ if not Abortable_Part_Executed then
+ Report.Failed ("Long delay: Abortable part was not executed");
+ end if;
+
+ if Triggering_Alternative_Executed then
+ Report.Failed ("Long delay: triggering alternative sequence " &
+ "of statements was executed");
+ end if;
+ end Long_Delay_Subtest;
+
+
+ Report.Result;
+
+end C974002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974003.a b/gcc/testsuite/ada/acats/tests/c9/c974003.a
new file mode 100644
index 000000000..c353a918d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974003.a
@@ -0,0 +1,249 @@
+-- C974003.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement
+-- is aborted if it does not complete before the triggering statement
+-- completes, where the triggering statement is a task entry call, and
+-- the entry call is queued.
+--
+-- Check that the sequence of statements of the triggering alternative
+-- is executed after the abortable part is left.
+--
+-- TEST DESCRIPTION:
+-- Declare a main procedure containing an asynchronous select with a task
+-- entry call as triggering statement. Force the entry call to be
+-- queued by having the task call a procedure, prior to the corresponding
+-- accept statement, which simulates a routine waiting for user input
+-- (with a delay).
+--
+-- Simulate a time-consuming routine in the abortable part by calling a
+-- procedure containing an infinite loop. Meanwhile, simulate input by
+-- the user (the delay expires), which causes the task to execute the
+-- accept statement corresponding to the triggering entry call.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+package C974003_0 is -- Automated teller machine abstraction.
+
+
+ -- Flags for testing purposes:
+ --
+ TC_Triggering_Statement_Completed : Boolean := False;
+ TC_Count : Integer := 1234; -- Global to defeat
+ -- optimization.
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+
+ Transaction_Canceled : exception;
+
+
+ task type ATM_Keyboard_Task is
+ entry Cancel_Pressed;
+ end ATM_Keyboard_Task;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type);
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974003_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+package body C974003_0 is
+
+
+ procedure Listen_For_Input (Key : out Key_Enum) is
+ begin
+ -- Model the situation where the user waits a bit for the card to
+ -- be validated, then presses cancel before it completes.
+
+ -- Delay long enough to force queuing of Keyboard.Cancel_Pressed.
+ delay ImpDef.Minimum_Task_Switch;
+
+ if Report.Equal (3, 3) then -- Always true.
+ Key := Cancel;
+ end if;
+ end Listen_For_Input;
+
+
+
+ -- One of these gets created as "Keyboard" for each transaction
+ --
+ task body ATM_Keyboard_Task is
+ Key_Pressed : Key_Enum := None;
+ begin
+ loop
+ -- Force entry calls
+ Listen_For_Input (Key_Pressed); -- to be queued,
+ -- then set guard to
+ -- true.
+ select
+ when (Key_Pressed = Cancel) => -- Guard is now
+ accept Cancel_Pressed do -- true, so accept
+ TC_Triggering_Statement_Completed := True; -- queued entry
+ end Cancel_Pressed; -- call.
+
+ -- User has cancelled the transaction so we exit the
+ -- loop and allow the task to terminate
+ exit;
+ else
+ Key_Pressed := None;
+ end select;
+
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
+ end ATM_Keyboard_Task;
+
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type) is
+ begin
+ Card.Number := 9999;
+ Card.PIN := 111;
+ end Read_Card;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ -- Simulate an exceedingly long validation activity.
+ loop -- Infinite loop.
+ TC_Count := (TC_Count + 1) mod Integer (Card.PIN);
+ -- Synch. point to allow transfer of control to Keyboard
+ -- task during this simulation
+ delay ImpDef.Minimum_Task_Switch;
+ exit when not Report.Equal (TC_Count, TC_Count); -- Always false.
+ end loop;
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "not executed");
+ if not TC_Triggering_Statement_Completed then
+ Report.Failed ("Triggering statement did not complete");
+ end if;
+ if TC_Count = 1234 then
+ -- Initial value is unchanged
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ end Perform_Transaction;
+
+
+end C974003_0;
+
+
+ --==================================================================--
+
+
+with Report;
+
+with C974003_0; -- Automated teller machine abstraction.
+use C974003_0;
+
+procedure C974003 is
+
+ Card_Data : ATM_Card_Type;
+
+begin -- Main program.
+
+ Report.Test ("C974003", "Asynchronous Select: Trigger is queued on a " &
+ "task entry and completes first");
+
+ Read_Card (Card_Data);
+
+ declare
+ -- Create the task for this transaction
+ Keyboard : C974003_0.ATM_Keyboard_Task;
+ begin
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ Keyboard.Cancel_Pressed; -- Entry call is initially queued, so
+ -- abortable part starts.
+
+ raise Transaction_Canceled; -- This is executed after Validate_Card
+ -- is aborted.
+ then abort
+ Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted
+ -- and completes before this call
+ -- finishes; it is then aborted.
+
+ -- Check that the whole of the abortable part is aborted, not
+ -- just the statement in the abortable part that was executing
+ -- at the time
+ Report.Failed ("Abortable part not aborted");
+
+ end select;
+
+ Perform_Transaction (Card_Data); -- Should not be reached.
+ exception
+ when Transaction_Canceled =>
+ if not TC_Triggering_Statement_Completed then
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed but triggering statement not complete");
+ end if;
+ if TC_Count = 1234 then
+ -- Initial value is unchanged
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ end;
+
+ Report.Result;
+
+end C974003;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974004.a b/gcc/testsuite/ada/acats/tests/c9/c974004.a
new file mode 100644
index 000000000..b1200c103
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974004.a
@@ -0,0 +1,273 @@
+-- C974004.A
+--
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement
+-- is aborted if it does not complete before the triggering statement
+-- completes, where the triggering statement is a task entry call,
+-- the entry call is queued, and the entry call completes by propagating
+-- an exception and that the sequence of statements of the triggering
+-- alternative is not executed after the abortable part is left and that
+-- the exception propagated by the entry call is re-raised immediately
+-- following the asynchronous select.
+--
+-- TEST DESCRIPTION:
+-- Declare a main procedure containing an asynchronous select with a task
+-- entry call as triggering statement. Force the entry call to be
+-- queued by having the task call a procedure, prior to the corresponding
+-- accept statement, which simulates a routine waiting for user input
+-- (with a delay).
+--
+-- Simulate a time-consuming routine in the abortable part by calling a
+-- procedure containing an infinite loop. Meanwhile, simulate input by
+-- the user (the delay expires), which causes the task to execute the
+-- accept statement corresponding to the triggering entry call. Raise
+-- an exception in the accept statement which is not handled by the task,
+-- and which is thus propagated to the caller.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+package C974004_0 is -- Automated teller machine abstraction.
+
+
+ -- Flags for testing purposes:
+
+ Count : Integer := 1234; -- Global to defeat
+ -- optimization.
+ Propagated_From_Task : exception;
+
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+
+ Transaction_Canceled : exception;
+
+
+ task type ATM_Keyboard_Task is
+ entry Cancel_Pressed;
+ end ATM_Keyboard_Task;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type);
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974004_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+package body C974004_0 is
+
+
+ procedure Listen_For_Input (Key : out Key_Enum) is
+ begin
+ -- Simulate the situation where a user waits a bit for the card to
+ -- be validated, then presses cancel before it completes.
+
+ -- Delay long enough to force queuing of Keyboard.Cancel_Pressed.
+ delay ImpDef.Clear_Ready_Queue;
+
+ if Report.Equal (3, 3) then -- Always true.
+ Key := Cancel;
+ end if;
+ end Listen_For_Input;
+
+
+ -- One of these gets created as "Keyboard" for each transaction
+ --
+ task body ATM_Keyboard_Task is
+ Key_Pressed : Key_Enum := None;
+ begin
+ loop
+ -- Force entry calls to be
+ Listen_For_Input (Key_Pressed); -- queued, then set guard to
+ -- true.
+ select
+ when (Key_Pressed = Cancel) => -- Guard is now true, so accept
+ accept Cancel_Pressed do -- queued entry call.
+ null; --:::: user code for cancel
+ -- Now simulate an unexpected exception arising in the
+ -- user code
+ raise Propagated_From_Task; -- Propagate an exception.
+
+ end Cancel_Pressed;
+
+ Report.Failed
+ ("Exception not propagated in ATM_Keyboard_Task");
+
+ -- User has canceled the transaction so we exit the
+ -- loop and allow the task to terminate
+ exit;
+ else
+ Key_Pressed := None;
+ end select;
+ end loop;
+ exception
+ when Propagated_From_Task =>
+ null; -- This is the expected test behavior
+ when others =>
+ Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
+ end ATM_Keyboard_Task;
+
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type) is
+ begin
+ Card.Number := 9999;
+ Card.PIN := 111;
+ end Read_Card;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ -- Simulate an exceedingly long validation activity.
+ loop -- Infinite loop.
+ Count := (Count + 1) mod Integer (Card.PIN);
+ -- Synch. point to allow transfer of control to Keyboard
+ -- task during this simulation
+ delay ImpDef.Minimum_Task_Switch;
+ exit when not Report.Equal (Count, Count); -- Always false.
+ end loop;
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Exception not re-raised immediately following " &
+ "asynchronous select");
+ if Count = 1234 then
+ -- Initial value is unchanged
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ end Perform_Transaction;
+
+
+end C974004_0;
+
+
+ --==================================================================--
+
+
+with Report;
+
+with C974004_0; -- Automated teller machine abstraction.
+use C974004_0;
+
+procedure C974004 is
+
+ Card_Data : ATM_Card_Type;
+
+begin -- Main program.
+
+ Report.Test ("C974004", "Asynchronous Select: Trigger is queued on a " &
+ "task entry and is completed first by an " &
+ "exception");
+
+ Read_Card (Card_Data);
+
+ begin
+
+ declare
+ -- Create the task for this transaction
+ Keyboard : C974004_0.ATM_Keyboard_Task;
+ begin
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ Keyboard.Cancel_Pressed; -- Entry call initially queued, so
+ -- abortable part starts.
+
+ raise Transaction_Canceled; -- Should not be executed.
+ then abort
+ Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted
+ -- and propagates an exception before
+ -- this call finishes; it is then
+ -- aborted.
+
+ -- Check that the whole of the abortable part is aborted, not
+ -- just the statement in the abortable part that was executing
+ -- at the time
+ Report.Failed ("Abortable part not aborted");
+ end select;
+ -- The propagated exception is
+ -- re-raised here; control passes to
+ -- the exception handler.
+
+ Perform_Transaction(Card_Data); -- Should not be reached.
+ exception
+ when Transaction_Canceled =>
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed");
+ when Propagated_From_Task =>
+ -- This is the expected test path
+ if Count = 1234 then
+ -- Initial value is unchanged
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ when Tasking_Error =>
+ Report.Failed ("Tasking_Error raised");
+ when others =>
+ Report.Failed ("Wrong exception raised");
+ end;
+
+ exception
+ when Propagated_From_Task =>
+ Report.Failed ("Correct exception raised at wrong level");
+ when others =>
+ Report.Failed ("Wrong exception raised at wrong level");
+ end;
+
+ Report.Result;
+
+end C974004;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974005.a b/gcc/testsuite/ada/acats/tests/c9/c974005.a
new file mode 100644
index 000000000..196a8edc0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974005.a
@@ -0,0 +1,259 @@
+-- C974005.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that Tasking_Error is raised at the point of an entry call
+-- which is the triggering statement of an asynchronous select, if
+-- the entry call is queued, but the task containing the entry completes
+-- before it can be accepted or canceled.
+--
+-- Check that the abortable part is aborted if it does not complete
+-- before the triggering statement completes.
+--
+-- Check that the sequence of statements of the triggering alternative
+-- is not executed.
+--
+-- TEST DESCRIPTION:
+-- Declare a main procedure containing an asynchronous select with a task
+-- entry call as triggering statement. Force the entry call to be
+-- queued by having the task call a procedure, prior to the corresponding
+-- accept statement, which simulates a routine waiting for user input
+-- (with a delay).
+--
+-- Simulate a time-consuming routine in the abortable part by calling a
+-- procedure containing an infinite loop. Meanwhile, simulate input by
+-- the user (the delay expires) which is NOT the input expected by the
+-- guard on the accept statement. The entry remains closed, and the
+-- task completes its execution. Since the entry was not accepted before
+-- its task completed, Tasking_Error is raised at the point of the entry
+-- call.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+package C974005_0 is -- Automated teller machine abstraction.
+
+
+ -- Flags for testing purposes:
+
+ Count : Integer := 1234;
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+
+ Transaction_Canceled : exception;
+
+
+ task type ATM_Keyboard_Task is
+ entry Cancel_Pressed;
+ end ATM_Keyboard_Task;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type);
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974005_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+package body C974005_0 is
+
+
+ procedure Listen_For_Input (Key : out Key_Enum) is
+ begin
+ -- Simulate the situation where a user waits a bit for the card to
+ -- be validated, then presses a transaction key (NOT Cancel).
+
+ -- Delay long enough to force queuing of Keyboard.Cancel_Pressed.
+ delay ImpDef.Clear_Ready_Queue;
+
+ if Report.Equal (3, 3) then -- Always true.
+ Key := Deposit; -- Cancel is NOT pressed.
+ end if;
+ end Listen_For_Input;
+
+
+ task body ATM_Keyboard_Task is
+ Key_Pressed : Key_Enum := None;
+ begin
+
+ -- Note: no loop. If the user does not press Cancel, the task completes.
+ -- In this model of the keyboard monitor, the user only gets one chance
+ -- to cancel the card validation.
+ -- Force entry
+ Listen_For_Input (Key_Pressed); -- calls to be
+ -- queued, but do
+ -- NOT set guard
+ -- to true.
+ select
+ when (Key_Pressed = Cancel) => -- Guard is false,
+ accept Cancel_Pressed do -- so entry call
+ Report.Failed ("Accept statement executed"); -- remains queued.
+ end Cancel_Pressed;
+ else -- Else alternative
+ Key_Pressed := None; -- executed, then
+ end select; -- task ends.
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in ATM_Keyboard_Task");
+ end ATM_Keyboard_Task;
+
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type) is
+ begin
+ Card.Number := 9999;
+ Card.PIN := 111;
+ end Read_Card;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ -- Simulate an exceedingly long validation activity.
+ loop -- Infinite loop.
+ Count := (Count + 1) mod Integer (Card.PIN);
+
+ -- Synch Point to allow transfer of control to Keyboard task
+ -- during this simulation
+ delay ImpDef.Minimum_Task_Switch;
+
+ exit when not Report.Equal (Count, Count); -- Always false.
+ end loop;
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Exception not re-raised immediately following " &
+ "asynchronous select");
+ if Count = 1234 then
+ -- Additional analysis added to aid developers
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ end Perform_Transaction;
+
+
+end C974005_0;
+
+
+ --==================================================================--
+
+
+with Report;
+
+with C974005_0; -- Automated teller machine abstraction.
+use C974005_0;
+
+procedure C974005 is
+
+ Card_Data : ATM_Card_Type;
+
+begin -- Main program.
+
+ Report.Test ("C974005", "ATC: trigger is queued but task terminates" &
+ " before call is serviced");
+
+ Read_Card (Card_Data);
+
+ begin
+
+ declare
+ Keyboard : C974005_0.ATM_Keyboard_Task;
+ begin
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ Keyboard.Cancel_Pressed; -- Entry call initially queued, so
+ -- abortable part starts.
+
+ -- Tasking_Error raised here when
+ -- Keyboard completes before entry
+ -- call can be accepted, and before
+ -- abortable part completes.
+
+ raise Transaction_Canceled; -- Should not be executed.
+ then abort
+ Validate_Card (Card_Data); -- Keyboard task completes before
+ -- Keyboard.Cancel_Pressed is
+ -- accepted, and before this call
+ -- finishes. Tasking_Error is raised
+ -- at the point of the entry call,
+ -- and this call is aborted.
+ -- Check that the whole of the abortable part is aborted, not just
+ -- the statement in the abortable part that was executing at
+ -- the time
+ Report.Failed ("Abortable part not aborted");
+ end select;
+ Perform_Transaction (Card_Data); -- Should not be reached.
+ exception
+ when Transaction_Canceled =>
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed");
+ when Tasking_Error =>
+ if Count = 1234 then
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ when others =>
+ Report.Failed ("Wrong exception raised");
+ end;
+
+ exception
+ when Tasking_Error =>
+ Report.Failed ("Correct exception raised at wrong level");
+ when others =>
+ Report.Failed ("Wrong exception raised at wrong level");
+ end;
+
+ Report.Result;
+
+end C974005;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974006.a b/gcc/testsuite/ada/acats/tests/c9/c974006.a
new file mode 100644
index 000000000..f6f4d92e8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974006.a
@@ -0,0 +1,197 @@
+-- C974006.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the sequence of statements of the triggering alternative
+-- of an asynchronous select statement is executed if the triggering
+-- statement is a protected entry call, and the entry is accepted
+-- immediately. Check that the corresponding entry body is executed
+-- before the sequence of statements of the triggering alternative.
+-- Check that the abortable part is not executed.
+--
+-- TEST DESCRIPTION:
+-- Declare a main procedure containing an asynchronous select with a
+-- protected entry call as triggering statement. Declare a protected
+-- procedure which sets the protected entry's barrier true. Force the
+-- entry call to be accepted immediately by calling this protected
+-- procedure prior to the asynchronous select. Since the entry call
+-- is accepted immediately, the abortable part should never start. When
+-- entry call completes, the sequence of statements of the triggering
+-- alternative should execute.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+package C974006_0 is -- Automated teller machine abstraction.
+
+
+ -- Flag for testing purposes:
+
+ Entry_Body_Executed : Boolean := False;
+
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+
+ Transaction_Canceled : exception;
+
+
+ protected type ATM_Keyboard_Protected is
+ entry Cancel_Pressed;
+ procedure Read_Key;
+ private
+ Last_Key_Pressed : Key_Enum := None;
+ end ATM_Keyboard_Protected;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type);
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974006_0;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C974006_0 is
+
+
+ protected body ATM_Keyboard_Protected is
+
+ entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is
+ begin
+ Entry_Body_Executed := True;
+ end Cancel_Pressed;
+
+ procedure Read_Key is
+ begin
+ -- Simulate a procedure which processes user keyboard input, and
+ -- which is called by some interrupt handler.
+ Last_Key_Pressed := Cancel;
+ end Read_Key;
+
+ end ATM_Keyboard_Protected;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type) is
+ begin
+ Card.Number := 9999;
+ Card.PIN := 111;
+ end Read_Card;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Abortable part executed");
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "not fully executed");
+ end Perform_Transaction;
+
+
+end C974006_0;
+
+
+ --==================================================================--
+
+
+with Report;
+
+with C974006_0; -- Automated teller machine abstraction.
+use C974006_0;
+
+procedure C974006 is
+
+ Card_Data : ATM_Card_Type;
+
+begin
+
+ Report.Test ("C974006", "ATC: trigger is protected entry call" &
+ " and completes first");
+
+ Read_Card (Card_Data);
+
+ declare
+ Keyboard : C974006_0.ATM_Keyboard_Protected;
+ begin
+
+ -- Simulate the situation where the user hits cancel before the
+ -- validation process can start:
+ Keyboard.Read_Key; -- Force Keyboard.Cancel_Pressed to
+ -- be accepted immediately.
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ Keyboard.Cancel_Pressed; -- Entry call is accepted immediately,
+ -- so abortable part does NOT start.
+
+ if not Entry_Body_Executed then -- Executes after entry completes.
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed before triggering statement complete");
+ end if;
+
+ raise Transaction_Canceled; -- Control passes to exception
+ -- handler.
+ then abort
+ Validate_Card (Card_Data); -- Should not be executed.
+ end select;
+ Perform_Transaction (Card_Data); -- Should not be reached.
+ exception
+ when Transaction_Canceled =>
+ null;
+ end;
+
+ Report.Result;
+
+end C974006;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974007.a b/gcc/testsuite/ada/acats/tests/c9/c974007.a
new file mode 100644
index 000000000..07007b9bb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974007.a
@@ -0,0 +1,205 @@
+-- C974007.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the sequence of statements of the triggering alternative
+-- of an asynchronous select statement is not executed if the triggering
+-- statement is a protected entry call, and the entry is not accepted
+-- before the abortable part completes. Check that execution continues
+-- immediately following the asynchronous select.
+--
+-- TEST DESCRIPTION:
+-- Declare a main procedure containing an asynchronous select with a
+-- protected entry call as triggering statement. Declare a protected
+-- procedure which sets the protected entry's barrier true. Ensure
+-- that the entry call is never accepted by not calling the protected
+-- procedure; the barrier remains false, and the entry call from
+-- asynchronous select is queued. Since the abortable part will complete
+-- before the entry is accepted, the sequence of statements of the
+-- triggering alternative is never executed.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+package C974007_0 is -- Automated teller machine abstraction.
+
+
+ -- Flags for testing purposes:
+ --
+ Abortable_Part_Executed : Boolean := False;
+ Perform_Transaction_Executed : Boolean := False;
+ Triggering_Statement_Executed : Boolean := False;
+
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+
+ Transaction_Canceled : exception;
+
+
+ protected type ATM_Keyboard_Protected is
+ entry Cancel_Pressed;
+ procedure Read_Key;
+ private
+ Last_Key_Pressed : Key_Enum := None;
+ end ATM_Keyboard_Protected;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type);
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974007_0;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C974007_0 is
+
+
+ protected body ATM_Keyboard_Protected is
+
+ -- Barrier is false for the live of the test
+ entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is
+ begin
+ Triggering_Statement_Executed := true; -- Test has failed
+ -- (Note: cannot call Report.Failed in the protected entry body]
+ end Cancel_Pressed;
+
+ procedure Read_Key is -- Never
+ begin -- called.
+ -- Simulate a procedure which reads user keyboard input, and
+ -- which is called by some interrupt handler.
+ Last_Key_Pressed := Cancel;
+ end Read_Key;
+
+ end ATM_Keyboard_Protected;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type) is
+ begin
+ Card.Number := 9999;
+ Card.PIN := 111;
+ end Read_Card;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ Abortable_Part_Executed := True;
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Perform_Transaction_Executed := True;
+ end Perform_Transaction;
+
+
+end C974007_0;
+
+
+ --==================================================================--
+with Report;
+
+with C974007_0; -- Automated teller machine abstraction.
+use C974007_0;
+
+procedure C974007 is
+
+ Card_Data : ATM_Card_Type;
+
+begin
+
+ Report.Test ("C974007", "ATC: trigger is protected entry call" &
+ " and abortable part completes first");
+
+ Read_Card (Card_Data);
+
+ declare
+ Keyboard : C974007_0.ATM_Keyboard_Protected;
+ begin
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ Keyboard.Cancel_Pressed; -- Barrier is never set true, so
+ -- entry call is queued and never
+ -- accepted.
+
+ raise Transaction_Canceled; -- Should not be executed.
+ then abort
+ Validate_Card (Card_Data); -- This call completes before
+ -- Keyboard.Cancel_Pressed can be
+ -- accepted.
+ end select;
+ Perform_Transaction (Card_Data); -- Execution proceeds here after
+ -- Validate_Card completes.
+ exception
+ when Transaction_Canceled =>
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed");
+ end;
+
+
+ if Triggering_Statement_Executed then
+ Report.Failed ("Triggering statement was executed");
+ end if;
+
+ if not Abortable_Part_Executed then
+ Report.Failed ("Abortable part not executed");
+ end if;
+
+ if not Perform_Transaction_Executed then
+ Report.Failed ("Statements following asynchronous select not " &
+ "executed");
+ end if;
+
+ Report.Result;
+
+end C974007;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974008.a b/gcc/testsuite/ada/acats/tests/c9/c974008.a
new file mode 100644
index 000000000..b76db7bd0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974008.a
@@ -0,0 +1,229 @@
+-- C974008.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement
+-- is not started if the triggering statement is a task entry call, and
+-- the entry call is not queued.
+--
+-- Check that the sequence of statements of the triggering alternative
+-- is executed after the abortable part is left.
+--
+-- TEST DESCRIPTION:
+-- Declare a main procedure containing an asynchronous select with a task
+-- entry call as triggering statement. Ensure that the task is waiting
+-- at the accept statement so the rendezvous is executed immediately (the
+-- entry call is not queued).
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+package C974008_0 is -- Automated teller machine abstraction.
+
+
+ -- Flags for testing purposes:
+
+ Triggering_Statement_Completed : Boolean := False;
+ Count : Integer := 1234; -- Global to defeat
+ -- optimization.
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+
+ Transaction_Canceled : exception;
+
+
+ task type ATM_Keyboard_Task is
+ entry Cancel_Pressed;
+ end ATM_Keyboard_Task;
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type);
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974008_0;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C974008_0 is
+
+
+ procedure Listen_For_Input (Key : out Key_Enum) is
+ begin
+ -- Simulate the situation where the user presses the cancel key
+ -- before the card is validated
+
+ -- press the cancel key immediately
+ Key := Cancel;
+
+ end Listen_For_Input;
+
+
+
+ -- One of these gets created as "Keyboard" for each transaction
+ --
+ task body ATM_Keyboard_Task is
+ Key_Pressed : Key_Enum := None;
+ begin
+ -- NOTE: Normal usage for this routine would be the loop with
+ -- the select statement included. This particular test
+ -- requires that the task be waiting at the accept
+ -- for the call. To ensure that this is the case the
+ -- extraneous commands are commented out (we leave them
+ -- in this form to show the reader the surrounds to the
+ -- fragment of code remaining)
+
+ -- loop
+
+ Listen_For_Input (Key_Pressed);
+
+ -- select
+ -- when (Key_Pressed = Cancel) => -- Guard is now
+ accept Cancel_Pressed do -- true, so accept
+ Triggering_Statement_Completed := True; -- queued entry
+ end Cancel_Pressed; -- call.
+
+ -- User has cancelled the transaction so we exit the
+ -- loop and allow the task to terminate
+ -- exit;
+ -- else
+ -- Key_Pressed := None;
+ -- end select;
+
+ -- end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
+ end ATM_Keyboard_Task;
+
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type) is
+ begin
+ Card.Number := 9999;
+ Card.PIN := 111;
+ end Read_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "not executed");
+ if not Triggering_Statement_Completed then
+ Report.Failed ("Triggering statement did not complete");
+ end if;
+ end Perform_Transaction;
+
+
+end C974008_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with C974008_0; -- Automated teller machine abstraction.
+use C974008_0;
+
+procedure C974008 is
+
+ Card_Data : ATM_Card_Type;
+
+begin -- Main program.
+
+ Report.Test ("C974008", "Asynchronous Select: Trigger is a call to a " &
+ "waiting task entry and completes immediately");
+
+ Read_Card (Card_Data);
+
+ declare
+ -- Create the task for this transaction
+ Keyboard : C974008_0.ATM_Keyboard_Task;
+ begin
+
+ -- Ensure task is waiting at the accept
+ -- This is the time required to activate another task and allow it
+ -- to run to its first accept statement.
+ --
+ delay ImpDef.Switch_To_New_Task;
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+ Keyboard.Cancel_Pressed; -- Entry call is executed immediately
+
+ raise Transaction_Canceled; -- This is executed after Validate_Card
+ -- is aborted.
+ then abort
+
+ -- In other similar tests Validate_Card is called here. In this
+ -- test we just check to see if the abortable part is called at
+ -- all. Since the triggering call is not queued the abortable
+ -- part should not be started
+ --
+ Report.Failed ("Abortable part started");
+
+ end select;
+
+ Perform_Transaction (Card_Data); -- Should not be reached.
+ exception
+ when Transaction_Canceled =>
+
+ if not Triggering_Statement_Completed then
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed but triggering statement not complete");
+ end if;
+
+ end;
+
+ Report.Result;
+
+end C974008;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974009.a b/gcc/testsuite/ada/acats/tests/c9/c974009.a
new file mode 100644
index 000000000..419f2a3e9
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974009.a
@@ -0,0 +1,206 @@
+-- C974009.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement
+-- is not started if the triggering statement is a task entry call,
+-- the entry call is not queued and the entry call completes by
+-- propagating an exception.
+--
+-- Check that the exception is properly propagated to the asynchronous
+-- select statement and thus the sequence of statements of the triggering
+-- alternative is not executed after the abortable part is left.
+--
+-- Check that the exception propagated by the entry call is re-raised
+-- immediately following the asynchronous select.
+--
+-- TEST DESCRIPTION:
+--
+-- Use a small subset of the base Automated teller machine simulation
+-- which is shown in greater detail in other tests of this series.
+-- Declare a main procedure containing an asynchronous select with a task
+-- entry call as triggering statement. Force the task to be waiting at
+-- the accept statement so that the call is not queued and the rendezvous
+-- is executed immediately. Simulate an unexpected exception in the
+-- rendezvous. Use stripped down versions of called procedures to check
+-- the correct path in the test.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+package C974009_0 is -- Automated teller machine abstraction.
+
+
+ Propagated_From_Task : exception;
+ Transaction_Canceled : exception;
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+ task type ATM_Keyboard_Task is
+ entry Cancel_Pressed;
+ end ATM_Keyboard_Task;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974009_0;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C974009_0 is
+
+
+
+ -- One of these gets created as "Keyboard" for each transaction
+ --
+ task body ATM_Keyboard_Task is
+ Key_Pressed : Key_Enum := None;
+ begin
+ accept Cancel_Pressed do -- queued entry call.
+ null; --:::: stub, user code for cancel
+ -- Now simulate an unexpected exception arising in the
+ -- user code
+ raise Propagated_From_Task; -- Propagate an exception.
+
+ end Cancel_Pressed;
+
+ Report.Failed ("Exception not propagated in ATM_Keyboard_Task");
+
+ exception
+ when Propagated_From_Task =>
+ null; -- This is the expected test behavior
+ when others =>
+ Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
+ end ATM_Keyboard_Task;
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Abortable part was executed");
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Exception not re-raised immediately following " &
+ "asynchronous select");
+ end Perform_Transaction;
+
+
+end C974009_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with C974009_0; -- Automated teller machine abstraction.
+use C974009_0;
+
+procedure C974009 is
+
+ Card_Data : ATM_Card_Type;
+
+begin -- Main program.
+
+ Report.Test ("C974009", "Asynchronous Select: Trigger is a call to a " &
+ "task entry, is not queued and is completed " &
+ "first by an exception");
+
+
+ begin
+
+ declare
+ -- Create the task for this transaction
+ Keyboard : C974009_0.ATM_Keyboard_Task;
+ begin
+
+ -- Ensure task is waiting a the accept so the call is not queued
+ -- This is the time required to activate another task and allow it
+ -- to run to its first accept statement
+ --
+ delay ImpDef.Switch_To_New_Task;
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+
+ Keyboard.Cancel_Pressed;
+
+ raise Transaction_Canceled; -- Should not be executed.
+ then abort
+ Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted
+ -- and propagates an exception before
+ -- this call is executed
+ end select;
+
+ -- The propagated exception is re-raised here.
+ Perform_Transaction(Card_Data); -- Should not be reached.
+
+ exception
+ when Transaction_Canceled =>
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed");
+ when Propagated_From_Task =>
+ null; -- This is the expected test path
+ when others =>
+ Report.Failed ("Wrong exception raised");
+ end;
+
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception raised");
+ end;
+
+ Report.Result;
+
+end C974009;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974010.a b/gcc/testsuite/ada/acats/tests/c9/c974010.a
new file mode 100644
index 000000000..caeb9d570
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974010.a
@@ -0,0 +1,209 @@
+-- C974010.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement
+-- is not started if the triggering statement is a task entry call to
+-- a task that has already terminated.
+--
+-- Check that Tasking_Error is properly propagated to the asynchronous
+-- select statement and thus the sequence of statements of the triggering
+-- alternative is not executed after the abortable part is left.
+--
+-- Check that Tasking_Error is re-raised immediately following the
+-- asynchronous select.
+--
+-- TEST DESCRIPTION:
+--
+-- Use a small subset of the base Automated Teller Machine simulation
+-- which is shown in greater detail in other tests of this series.
+-- Declare a main procedure containing an asynchronous select with a task
+-- entry call as triggering statement. Ensure that the task is
+-- terminated before the entry call. Use stripped down versions of
+-- the called procedures to check the correct path in the test.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+package C974010_0 is -- Automated teller machine abstraction.
+
+
+ Transaction_Canceled : exception;
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+ task type ATM_Keyboard_Task is
+ entry Cancel_Pressed;
+ end ATM_Keyboard_Task;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974010_0;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C974010_0 is
+
+
+
+ -- One of these gets created as "Keyboard" for each transaction
+ --
+ task body ATM_Keyboard_Task is
+ TC_Suicide : exception;
+ Key_Pressed : Key_Enum := None;
+ begin
+ raise TC_Suicide; -- Simulate early, unexpected termination
+
+ accept Cancel_Pressed do -- queued entry call.
+ null; --:::: user code for cancel
+
+ end Cancel_Pressed;
+
+ exception
+ when TC_Suicide =>
+ null; -- This is the expected test behavior
+ when others =>
+ Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
+ end ATM_Keyboard_Task;
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Abortable part was executed");
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ Report.Failed ("Exception not re-raised immediately following " &
+ "asynchronous select");
+ end Perform_Transaction;
+
+
+end C974010_0;
+
+
+ --==================================================================--
+
+
+with Report;
+with ImpDef;
+
+with C974010_0; -- Automated teller machine abstraction.
+use C974010_0;
+
+procedure C974010 is
+
+ Card_Data : ATM_Card_Type;
+ TC_Tasking_Error_Handled : Boolean := false;
+
+begin -- Main program.
+
+ Report.Test ("C974010", "Asynchronous Select: Trigger is a call to a " &
+ "task entry of a task that is already completed");
+
+
+ declare
+ -- Create the task for this transaction
+ Keyboard : C974010_0.ATM_Keyboard_Task;
+ begin
+
+ -- Ensure the task is already completed before calling
+ --
+ while not Keyboard'terminated loop
+ delay ImpDef.Minimum_Task_Switch;
+ end loop;
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+
+ Keyboard.Cancel_Pressed;
+
+ raise Transaction_Canceled; -- Should not be executed.
+
+ then abort
+
+ -- Since the triggering call is not queued the abortable part
+ -- should not be executed.
+ --
+ Validate_Card (Card_Data);
+
+ end select;
+ --
+ -- The propagated exception is re-raised here.
+
+ Perform_Transaction(Card_Data); -- Should not be reached.
+
+ exception
+ when Transaction_Canceled =>
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed");
+ when Tasking_Error =>
+ -- This is the expected test path
+ TC_Tasking_Error_Handled := true;
+ when others =>
+ Report.Failed ("Wrong exception raised: ");
+ end;
+
+
+ if not TC_Tasking_Error_Handled then
+ Report.Failed ("Tasking_Error not properly propagated");
+ end if;
+
+ Report.Result;
+
+exception
+ when Tasking_Error =>
+ Report.Failed ("Tasking_Error propagated to wrong handler");
+ Report.Result;
+
+
+end C974010;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974011.a b/gcc/testsuite/ada/acats/tests/c9/c974011.a
new file mode 100644
index 000000000..4682db628
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974011.a
@@ -0,0 +1,275 @@
+-- C974011.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the sequence of statements of the triggering alternative
+-- of an asynchronous select statement is not executed if the triggering
+-- statement is a task entry call and the entry is not accepted
+-- before the abortable part completes.
+-- Check that the call queued on the entry is cancelled
+--
+-- TEST DESCRIPTION:
+-- Declare a main procedure containing an asynchronous select with a task
+-- entry call as triggering statement. Force the entry call to be
+-- queued by having the task call a procedure, prior to the corresponding
+-- accept statement, which simulates (with a delay) a routine waiting
+-- for user input
+--
+-- Once the call is known to be queued, complete the abortable part.
+-- Check that the rendezvous (and thus the trigger) does not complete.
+-- Then clear the barrier and check that the entry has been cancelled
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 28 Nov 95 SAIC Eliminated shared global variable for ACVC 2.0.1
+--
+--!
+
+with ImpDef;
+--
+package C974011_0 is -- Automated teller machine abstraction.
+
+
+
+ type Key_Enum is (None, Cancel, Deposit, Withdraw);
+
+ protected Key_PO is
+ procedure Set (K : Key_Enum);
+ function Value return Key_Enum;
+ private
+ Current : Key_Enum := None;
+ end Key_PO;
+
+
+ -- Flags for testing purposes
+ TC_Abortable_Part_Completed : Boolean := False;
+ TC_Rendezvous_Entered : Boolean := False;
+ TC_Delay_Time : constant duration := ImpDef.Switch_To_New_Task;
+
+
+ Count : Integer := 1234; -- Global to defeat optimization.
+
+
+ type Card_Number_Type is private;
+ type Card_PIN_Type is private;
+ type ATM_Card_Type is private;
+
+
+ Transaction_Canceled : exception;
+
+
+ task type ATM_Keyboard_Task is
+ entry Cancel_Pressed;
+ end ATM_Keyboard_Task;
+
+ procedure Read_Card (Card : in out ATM_Card_Type);
+
+ procedure Validate_Card (Card : in ATM_Card_Type);
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type);
+
+private
+
+ type Card_Number_Type is range 1 .. 9999;
+ type Card_PIN_Type is range 100 .. 999;
+
+ type ATM_Card_Type is record
+ Number : Card_Number_Type;
+ PIN : Card_PIN_Type;
+ end record;
+
+end C974011_0;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C974011_0 is
+
+ protected body Key_PO is
+ procedure Set (K : Key_Enum) is
+ begin
+ Current := K;
+ end Set;
+
+ function Value return Key_Enum is
+ begin
+ return Current;
+ end Value;
+ end Key_PO;
+
+
+ procedure Listen_For_Input (Key : out Key_Enum) is
+ begin
+ -- Model the situation where the user does not press cancel thus
+ -- allowing validation to complete
+
+ delay TC_Delay_Time; -- Long enough to force queuing on
+ -- Keyboard.Cancel_Pressed.
+
+ Key := Key_PO.Value;
+
+ end Listen_For_Input;
+
+
+
+ -- One of these gets created as "Keyboard" for each transaction
+ --
+ task body ATM_Keyboard_Task is
+ Key_Pressed : Key_Enum;
+ begin
+ loop
+ -- Force entry calls
+ Listen_For_Input (Key_Pressed); -- to be queued,
+
+ select
+ when (Key_Pressed = Cancel) =>
+ accept Cancel_Pressed do
+ TC_Rendezvous_Entered := True;
+ end Cancel_Pressed;
+
+ -- User has cancelled the transaction so we exit the
+ -- loop and allow the task to terminate
+ exit;
+ else
+ delay ImpDef.Switch_To_New_Task;
+ end select;
+
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
+ end ATM_Keyboard_Task;
+
+
+
+ procedure Read_Card (Card : in out ATM_Card_Type) is
+ begin
+ Card.Number := 9999;
+ Card.PIN := 111;
+ end Read_Card;
+
+
+ procedure Validate_Card (Card : in ATM_Card_Type) is
+ begin
+ Count := (Count + 1) mod Integer (Card.PIN);
+
+ -- Simulate a validation activity which is longer than the time
+ -- taken in Listen_For_Input but not inordinately so.
+ delay TC_Delay_Time * 2;
+
+ end Validate_Card;
+
+
+ procedure Perform_Transaction (Card : in ATM_Card_Type) is
+ begin
+ if TC_Rendezvous_Entered then
+ Report.Failed ("Triggering statement completed");
+ end if;
+ if Count = 1234 then
+ -- Initial value is unchanged
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ if not TC_Abortable_Part_Completed then
+ Report.Failed ("Abortable part did not complete");
+ end if;
+ end Perform_Transaction;
+
+
+end C974011_0;
+
+
+ --==================================================================--
+
+
+with Report;
+
+with C974011_0; -- Automated teller machine abstraction.
+use C974011_0;
+
+procedure C974011 is
+
+ Card_Data : ATM_Card_Type;
+
+begin -- Main program.
+
+ Report.Test ("C974011", "Asynchronous Select: Trigger is queued on a " &
+ "task entry and the abortable part " &
+ "completes first");
+
+ Read_Card (Card_Data);
+
+ declare
+ -- Create the task for this transaction
+ Keyboard : C974011_0.ATM_Keyboard_Task;
+ begin
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+
+ Keyboard.Cancel_Pressed; -- Entry call is initially queued, so
+ -- abortable part starts.
+ raise Transaction_Canceled; -- This would be executed if we
+ -- completed the rendezvous
+ then abort
+
+ Validate_Card (Card_Data);
+ TC_Abortable_Part_Completed := true;
+
+ end select;
+
+ Perform_Transaction (Card_Data);
+
+
+ -- Now clear the entry barrier to allow the rendezvous to complete
+ -- if the triggering call has not been cancelled
+ Key_PO.Set (Cancel);
+ --
+ delay TC_Delay_Time; -- to allow it all to take place
+
+ if TC_Rendezvous_Entered then
+ Report.Failed ("Triggering Call was not cancelled");
+ end if;
+
+ abort Keyboard; -- clean up. (Note: the task will only exit the
+ -- loop and terminate if the call hanging on the
+ -- entry is executed.)
+
+ exception
+ when Transaction_Canceled =>
+ Report.Failed ("Triggering alternative sequence of statements " &
+ "executed");
+ when Others =>
+ Report.Failed ("Unexpected exception in the Main");
+ end;
+
+ Report.Result;
+
+end C974011;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974012.a b/gcc/testsuite/ada/acats/tests/c9/c974012.a
new file mode 100644
index 000000000..4e43c72a8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974012.a
@@ -0,0 +1,165 @@
+-- C974012.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement is
+-- aborted if it does not complete before the triggering statement
+-- completes, where the triggering statement is a call on a protected
+-- entry which is queued.
+--
+-- TEST DESCRIPTION:
+-- A fraction of in-line code is simulated. A voltage deficiency causes
+-- the routine to seek an alternate best-cost route on an electrical grid
+-- system.
+--
+-- An asynchronous select is used with the triggering alternative being a
+-- call to a protected entry with a barrier. The abortable part is a
+-- routine simulating the lengthy alternate path negotiation. The entry
+-- barrier would be cleared if the voltage deficiency is rectified before
+-- the alternate can be found thus nullifying the need for the alternate.
+--
+-- The test simulates a return to normal in the middle of the
+-- negotiation. The barrier is cleared, the triggering alternative
+-- completes first and the abortable part should be aborted.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+with ImpDef;
+
+procedure C974012 is
+
+ subtype Grid_Path is string(1..21);
+ subtype Deficiency is integer range 100..1_000; -- in MWh
+
+ New_Path : Grid_Path;
+ Dummy_Deficiency : Deficiency := 520;
+ Path_Available : Boolean := false;
+
+ TC_Terminate_Negotiation_Executed : Boolean := false;
+ TC_Trigger_Completed : Boolean := false;
+ TC_Negotiation_Completed : Boolean := false;
+
+ protected Local_Deficit is
+ procedure Set_Good_Voltage;
+ procedure Bad_Voltage;
+ entry Terminate_Negotiation;
+ private
+ Good_Voltage : Boolean := false; -- barrier
+ end Local_Deficit;
+
+ protected body Local_Deficit is
+
+ procedure Set_Good_Voltage is
+ begin
+ Good_Voltage := true;
+ end Set_Good_Voltage;
+
+ procedure Bad_Voltage is
+ begin
+ Good_Voltage := false;
+ end Bad_Voltage;
+
+ -- Trigger is queued on this entry with barrier condition
+ entry Terminate_Negotiation when Good_Voltage is
+ begin
+ -- complete the triggering call thus terminating grid_path
+ -- negotiation.
+ null; --::: stub - signal main board
+ TC_Terminate_Negotiation_Executed := true; -- show path traversal
+ end Terminate_Negotiation;
+
+ end Local_Deficit;
+
+
+ -- Routine to find the most cost effective grid path for this
+ -- particular deficiency at this particular time
+ --
+ procedure Path_Negotiation (Requirement : in Deficiency;
+ Best_Path : out Grid_Path ) is
+
+ Dummy_Path : Grid_Path := "NYC.425_NY.227_NH.132";
+ Match : Deficiency := Report.Ident_Int (Requirement);
+
+ begin
+ --
+ null; --::: stub
+ --
+ -- Simulate a lengthy path negotiation
+ for i in 1..5 loop
+ delay ImpDef.Minimum_Task_Switch;
+ -- Part of the way through the negotiation simulate some external
+ -- event returning the voltage to acceptable level
+ if i = 3 then
+ Local_Deficit.Set_Good_Voltage; -- clear the barrier
+ end if;
+ end loop;
+
+ Best_Path := Dummy_Path;
+ TC_Negotiation_Completed := true;
+
+ end Path_Negotiation;
+
+
+
+begin
+
+ Report.Test ("C974012", "Asynchronous Select: Trigger is queued on a " &
+ "protected entry and completes before the " &
+ "abortable part");
+
+ -- ::::::::: Fragment of code
+
+ Local_Deficit.Bad_Voltage; -- Set barrier condition
+
+ -- For the given voltage deficiency start negotiating the best grid
+ -- path. If voltage returns to acceptable level cancel the negotiation
+ --
+ select
+ -- Prepare to terminate the Path_Negotiation if voltage improves
+ Local_Deficit.Terminate_Negotiation;
+ TC_Trigger_Completed := true;
+ then abort
+ Path_Negotiation (Dummy_Deficiency, New_Path) ;
+ Path_Available := true;
+ end select;
+ -- :::::::::
+
+ if not TC_Terminate_Negotiation_Executed or else not
+ TC_Trigger_Completed then
+ Report.Failed ("Unexpected test path taken");
+ end if;
+
+ if Path_Available or else TC_Negotiation_Completed then
+ Report.Failed ("Abortable part was not aborted");
+ end if;
+ Report.Result;
+
+end C974012;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974013.a b/gcc/testsuite/ada/acats/tests/c9/c974013.a
new file mode 100644
index 000000000..4a930da93
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974013.a
@@ -0,0 +1,167 @@
+-- C974013.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that the abortable part of an asynchronous select statement
+-- is aborted if it does not complete before the triggering statement
+-- completes, where the triggering statement is a delay_until
+-- statement.
+--
+-- Check that the sequence of statements of the triggering alternative
+-- is executed after the abortable part is left.
+--
+-- TEST DESCRIPTION:
+-- Declare a task with an accept statement containing an asynchronous
+-- select with a delay_until triggering statement. Parameterize
+-- the accept statement with the amount of time to be added to the
+-- current time to be used for the delay. Simulate a time-consuming
+-- calculation by declaring a procedure containing an infinite loop.
+-- Call this procedure in the abortable part.
+--
+-- The delay will expire before the abortable part completes, at which
+-- time the abortable part is aborted, and the sequence of statements
+-- following the triggering statement is executed.
+--
+-- Main test logic is identical to c974001 which uses simple delay
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 28 Nov 95 SAIC Fixed problems for ACVC 2.0.1.
+--
+--!
+
+with Report;
+with ImpDef;
+with Ada.Calendar;
+
+procedure C974013 is
+
+
+ --========================================================--
+
+ function "+" (Left : Ada.Calendar.Time; Right: Duration)
+ return Ada.Calendar.Time renames Ada.Calendar."+";
+
+
+ Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task;
+ Calculation_Canceled : exception;
+
+ Count : Integer := 1234;
+ procedure Lengthy_Calculation is
+ begin
+ -- Simulate a non-converging calculation.
+ loop -- Infinite loop.
+ Count := (Count + 1) mod 10;
+ exit when not Report.Equal (Count, Count); -- Condition always false.
+ delay 0.0; -- abort completion point
+ end loop;
+ end Lengthy_Calculation;
+
+
+ --========================================================--
+
+
+ task type Timed_Calculation is
+ entry Calculation (Time_Limit : in Duration);
+ end Timed_Calculation;
+
+
+ task body Timed_Calculation is
+ Delay_Time : Ada.Calendar.Time;
+ begin
+ loop
+ select
+ accept Calculation (Time_Limit : in Duration) do
+
+ -- We have to construct an "until" time artificially
+ -- as we have no control over when the test will be run
+ --
+ Delay_Time := Ada.Calendar.Clock + Time_Limit;
+
+ -- --
+ -- Asynchronous select is tested here --
+ -- --
+
+ select
+
+ delay until Delay_Time; -- Time not reached yet, so
+ -- Lengthy_Calculation starts.
+
+ raise Calculation_Canceled; -- This is executed after
+ -- Lengthy_Calculation aborted.
+
+ then abort
+
+ Lengthy_Calculation; -- Delay expires before complete,
+ -- so this call is aborted.
+ -- Check that the whole of the abortable part is aborted,
+ -- not just the statement in the abortable part that was
+ -- executing at the time
+ Report.Failed ("Abortable part not aborted");
+
+ end select;
+
+ Report.Failed ("Triggering alternative sequence of " &
+ "statements not executed");
+
+ exception -- New Ada 9x: handler within accept
+ when Calculation_Canceled =>
+ if Count = 1234 then
+ Report.Failed ("Abortable part did not execute");
+ end if;
+ end Calculation;
+ or
+ terminate;
+ end select;
+ end loop;
+ exception
+ when others =>
+ Report.Failed ("Unexpected exception in Timed_Calculation task");
+ end Timed_Calculation;
+
+
+ --========================================================--
+
+
+
+begin -- Main program.
+
+ Report.Test ("C974013", "Asynchronous Select: Trigger is delay_until " &
+ "which completes before abortable part");
+
+ declare
+ Timed : Timed_Calculation; -- Task.
+ begin
+ Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select
+ -- inside accept block.
+ exception
+ when Calculation_Canceled =>
+ Report.Failed ("wrong exception handler used");
+ end;
+
+ Report.Result;
+
+end C974013;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974014.a b/gcc/testsuite/ada/acats/tests/c9/c974014.a
new file mode 100644
index 000000000..03ca915f8
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c974014.a
@@ -0,0 +1,132 @@
+-- C974014.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that if the triggering alternative of an asynchronous select
+-- statement is a delay and the abortable part completes before the delay
+-- expires then the delay is cancelled and the optional statements in the
+-- triggering part are not performed. In particular, check the case of
+-- the ATC in non-tasking code.
+--
+-- TEST DESCRIPTION:
+-- A fraction of in-line code is simulated. An asynchronous select
+-- is used with a triggering delay of several minutes. The abortable
+-- part, which is simulating a very lengthy, time consuming procedure
+-- actually returns almost immediately thus ensuring that it completes
+-- first. At the conclusion, if a substantial amount of time has passed
+-- the delay is assumed not to have been cancelled.
+-- (based on example in LRM 9.7.4)
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+
+with Report;
+with Ada.Calendar;
+
+procedure C974014 is
+
+ function "-" (Left, Right : Ada.Calendar.Time)
+ return Duration renames Ada.Calendar."-";
+
+ TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
+ TC_Elapsed_Time : duration;
+
+ Maximum_Allowable_Time : duration := 300.0; -- for Calculate_Gamma_Function
+
+begin
+
+ Report.Test ("C974014", "ATC: When abortable part completes before " &
+ "a triggering delay, check that the delay " &
+ "is cancelled & optional statements " &
+ "are not performed");
+
+ declare -- encapsulate test code
+
+ type Gamma_Index is digits 5; -- float precision
+
+ -- (These two fields are assumed filled elsewhere)
+ Input_Field, Result_of_Beta : Gamma_Index;
+
+ -- Notify and take corrective action in the event that
+ -- the procedure Calculate_Gamma_Function does not converge.
+ --
+ procedure Non_Convergent is
+ begin
+ null; -- stub
+
+ Report.Failed ("Optional statements in triggering part" &
+ " were performed");
+ end Non_Convergent;
+
+
+ -- This is a very time consuming calculation. It is possible,
+ -- that, with certain parameters, it will not converge. If it
+ -- runs for more than Maximum_Allowable_Time it is considered
+ -- not to be convergent and should be aborted.
+ --
+ Procedure Calculate_Gamma_Function (X, Y : Gamma_Index) is
+ begin
+ null; -- Stub
+ --
+ end Calculate_Gamma_Function;
+
+ begin -- declare
+
+ -- ..... Isolated segment of inline code
+
+ -- Now Print Gamma Function (abort and display if not convergent)
+ --
+ select
+ delay Maximum_Allowable_Time; -- for Calculate_Gamma_Function
+ Non_Convergent; -- Display error and flag result as failed
+
+ then abort
+ Calculate_Gamma_Function (Input_Field, Result_of_Beta);
+ end select;
+
+ -- ..... End of Isolated segment of inline code
+
+ end; -- declare
+
+ TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time;
+
+ -- Note: We are not checking for "cancellation within a reasonable time",
+ -- we are checking for cancellation/non-cancellation of the delay. We
+ -- use a number which, if exceeded, means that the delay was not
+ -- cancelled and has proceeded to full term.
+ --
+ if ( TC_Elapsed_Time > Maximum_Allowable_Time/2 ) then
+ -- Test time exceeds a reasonable value.
+ Report.Failed ("Triggering delay statement was not cancelled");
+ end if;
+
+
+ Report.Result;
+
+end C974014;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c980001.a b/gcc/testsuite/ada/acats/tests/c9/c980001.a
new file mode 100644
index 000000000..3bd4196f0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c980001.a
@@ -0,0 +1,303 @@
+-- C980001.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that when a construct is aborted the execution of an Initialize
+-- procedure as the last step of the default initialization of a
+-- controlled object is abort-deferred.
+--
+-- Check that when a construct is aborted the execution of a Finalize
+-- procedure as part of the finalization of a controlled object is
+-- abort-deferred.
+--
+-- Check that an assignment operation to an object with a controlled
+-- part is an abort-deferred operation.
+--
+-- TEST DESCRIPTION:
+-- The controlled operations which are being tested call a subprogram
+-- which guarantees that the enclosing operation becomes aborted.
+--
+-- Each object is created with a unique value to prevent optimizations
+-- due to the values being the same.
+--
+-- Two protected objects are utilized to warrant that the operations
+-- are delayed in their execution until such time that the abort is
+-- processed. The object Hold_Up is used to hold the targeted
+-- operation in execution, the object Progress is used to communicate
+-- to the driver software that progress is indeed being made.
+--
+--
+-- CHANGE HISTORY:
+-- 01 MAY 95 SAIC Initial version
+-- 01 MAY 96 SAIC Revised for 2.1
+-- 11 DEC 96 SAIC Final revision for 2.1
+-- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock
+--!
+
+---------------------------------------------------------------- C980001_0
+
+with Impdef;
+with Ada.Finalization;
+package C980001_0 is
+
+ A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0;
+ Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration
+ := Impdef.Switch_To_New_Task * 4.0;
+
+ function TC_Unique return Integer;
+
+ type Sticks_In_Initialize is new Ada.Finalization.Controlled with record
+ Item: Integer := TC_Unique;
+ end record;
+ procedure Initialize( AV: in out Sticks_In_Initialize );
+
+ type Sticks_In_Adjust is new Ada.Finalization.Controlled with record
+ Item: Integer := TC_Unique;
+ end record;
+ procedure Adjust ( AV: in out Sticks_In_Adjust );
+
+ type Sticks_In_Finalize is new Ada.Finalization.Controlled with record
+ Item: Integer := TC_Unique;
+ end record;
+ procedure Finalize ( AV: in out Sticks_In_Finalize );
+
+ Initialize_Called : Boolean := False;
+ Adjust_Called : Boolean := False;
+ Finalize_Called : Boolean := False;
+
+ protected type Sticker is
+ entry Lock;
+ procedure Unlock;
+ function Is_Locked return Boolean;
+ private
+ Locked : Boolean := False;
+ end Sticker;
+
+ Hold_Up : Sticker;
+ Progress : Sticker;
+
+ procedure Fail_And_Clear( Message : String );
+
+
+end C980001_0;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+with TCTouch;
+package body C980001_0 is
+
+ TC_Master_Value : Integer := 0;
+
+
+ function TC_Unique return Integer is -- make all values unique.
+ begin
+ TC_Master_Value := TC_Master_Value +1;
+ return TC_Master_Value;
+ end TC_Unique;
+
+ protected body Sticker is
+
+ entry Lock when not Locked is
+ begin
+ Locked := True;
+ end Lock;
+
+ procedure Unlock is
+ begin
+ Locked := False;
+ end Unlock;
+
+ function Is_Locked return Boolean is
+ begin
+ return Locked;
+ end Is_Locked;
+
+ end Sticker;
+
+ procedure Initialize( AV: in out Sticks_In_Initialize ) is
+ begin
+ TCTouch.Touch('I'); -------------------------------------------------- I
+ Hold_Up.Unlock; -- cause the select to abort
+ Initialize_Called := True;
+ AV.Item := TC_Unique;
+ TCTouch.Touch('i'); -------------------------------------------------- i
+ Progress.Unlock; -- allows Wait_Your_Turn to continue
+ end Initialize;
+
+ procedure Adjust ( AV: in out Sticks_In_Adjust ) is
+ begin
+ TCTouch.Touch('A'); -------------------------------------------------- A
+ Hold_Up.Unlock; -- cause the select to abort
+ Adjust_Called := True;
+ AV.Item := TC_Unique;
+ TCTouch.Touch('a'); -------------------------------------------------- a
+ Progress.Unlock;
+ end Adjust;
+
+ procedure Finalize ( AV: in out Sticks_In_Finalize ) is
+ begin
+ TCTouch.Touch('F'); -------------------------------------------------- F
+ Hold_Up.Unlock; -- cause the select to abort
+ Finalize_Called := True;
+ AV.Item := TC_Unique;
+ TCTouch.Touch('f'); -------------------------------------------------- f
+ Progress.Unlock;
+ end Finalize;
+
+ procedure Fail_And_Clear( Message : String ) is
+ begin
+ Report.Failed(Message);
+ Hold_Up.Unlock;
+ Progress.Unlock;
+ end Fail_And_Clear;
+
+end C980001_0;
+
+---------------------------------------------------------------------------
+
+with Report;
+with TCTouch;
+with Impdef;
+with C980001_0;
+procedure C980001 is
+
+ procedure Check_Initialize_Conditions is
+ begin
+ if not C980001_0.Initialize_Called then
+ C980001_0.Fail_And_Clear("Initialize did not correctly complete");
+ end if;
+ TCTouch.Validate("Ii", "Initialization Sequence");
+ end Check_Initialize_Conditions;
+
+ procedure Check_Adjust_Conditions is
+ begin
+ if not C980001_0.Adjust_Called then
+ C980001_0.Fail_And_Clear("Adjust did not correctly complete");
+ end if;
+ TCTouch.Validate("Aa", "Adjust Sequence");
+ end Check_Adjust_Conditions;
+
+ procedure Check_Finalize_Conditions is
+ begin
+ if not C980001_0.Finalize_Called then
+ C980001_0.Fail_And_Clear("Finalize did not correctly complete");
+ end if;
+ TCTouch.Validate("FfFfFf", "Finalization Sequence",
+ Order_Meaningful => False);
+ end Check_Finalize_Conditions;
+
+ procedure Wait_Your_Turn is
+ Overrun : Natural := 0;
+ begin
+ while C980001_0.Progress.Is_Locked loop -- and waits
+ delay C980001_0.A_Little_While;
+ Overrun := Overrun +1;
+ if Overrun > 10 then
+ C980001_0.Fail_And_Clear("Overrun expired lock");
+ end if;
+ end loop;
+ end Wait_Your_Turn;
+
+begin -- Main test procedure.
+
+ Report.Test ("C980001", "Check the interaction between asynchronous " &
+ "transfer of control and controlled types" );
+
+ C980001_0.Progress.Lock;
+ C980001_0.Hold_Up.Lock;
+
+ select
+ C980001_0.Hold_Up.Lock; -- Init will unlock
+
+ Wait_Your_Turn; -- abortable part is stuck in Initialize
+ Check_Initialize_Conditions;
+
+ then abort
+ declare
+ Object : C980001_0.Sticks_In_Initialize;
+ begin
+ delay Impdef.Minimum_Task_Switch;
+ if Report.Ident_Int( Object.Item ) /= Object.Item then
+ Report.Failed("Optimization foil caused failure");
+ end if;
+ C980001_0.Fail_And_Clear(
+ "Initialize test executed beyond expected region");
+ end;
+ end select;
+
+ C980001_0.Progress.Lock;
+
+ select
+ C980001_0.Hold_Up.Lock; -- Adjust will unlock
+
+ Wait_Your_Turn; -- abortable part is stuck in Adjust
+ Check_Adjust_Conditions;
+
+ then abort
+ declare
+ Object1 : C980001_0.Sticks_In_Adjust;
+ Object2 : C980001_0.Sticks_In_Adjust;
+ begin
+ Object1 := Object2;
+ delay Impdef.Minimum_Task_Switch;
+ if Report.Ident_Int( Object2.Item )
+ /= Report.Ident_Int( Object1.Item ) then
+ Report.Failed("Optimization foil 1 caused failure");
+ end if;
+ C980001_0.Fail_And_Clear("Adjust test executed beyond expected region");
+ end;
+ end select;
+
+ C980001_0.Progress.Lock;
+
+ select
+ C980001_0.Hold_Up.Lock; -- Finalize will unlock
+
+ Wait_Your_Turn; -- abortable part is stuck in Finalize
+ Check_Finalize_Conditions;
+
+ then abort
+ declare
+ Object1 : C980001_0.Sticks_In_Finalize;
+ Object2 : C980001_0.Sticks_In_Finalize;
+ begin
+ Object1 := Object2; -- cause a finalize call
+ delay Impdef.Minimum_Task_Switch;
+ if Report.Ident_Int( Object2.Item )
+ /= Report.Ident_Int( Object1.Item ) then
+ Report.Failed("Optimization foil 2 caused failure");
+ end if;
+ C980001_0.Fail_And_Clear(
+ "Finalize test executed beyond expected region");
+ end;
+ end select;
+
+ Report.Result;
+
+exception
+ when others => C980001_0.Fail_And_Clear("Exception in main");
+ Report.Result;
+end C980001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c980002.a b/gcc/testsuite/ada/acats/tests/c9/c980002.a
new file mode 100644
index 000000000..f2b9c5247
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c980002.a
@@ -0,0 +1,165 @@
+-- C980002.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+-- Check that aborts are deferred during protected actions.
+--
+-- TEST DESCRIPTION:
+-- This test uses an asynchronous transfer of control to attempt
+-- to abort a protected operation. The protected operation
+-- includes several requeues to check that the requeue does not
+-- allow the abort to occur.
+--
+--
+-- CHANGE HISTORY:
+-- 30 OCT 95 SAIC ACVC 2.1
+--
+--!
+
+with Report;
+procedure C980002 is
+
+ Max_Checkpoints : constant := 7;
+ type Checkpoint_ID is range 1..Max_Checkpoints;
+ type Points_Array is array (Checkpoint_ID) of Boolean;
+begin
+ Report.Test ("C980002",
+ "Check that aborts are deferred during a protected action" &
+ " including requeues");
+
+ declare -- test encapsulation
+
+ protected Checkpoint is
+ procedure Got_Here (Id : Checkpoint_ID);
+ function Results return Points_Array;
+ private
+ Reached_Points : Points_Array := (others => False);
+ end Checkpoint;
+
+ protected body Checkpoint is
+ procedure Got_Here (Id : Checkpoint_ID) is
+ begin
+ Reached_Points (Id) := True;
+ end Got_Here;
+
+ function Results return Points_Array is
+ begin
+ return Reached_Points;
+ end Results;
+ end Checkpoint;
+
+
+ protected Start_Here is
+ entry AST_Waits_Here;
+ entry Start_PO;
+ private
+ Open : Boolean := False;
+ entry First_Stop;
+ end Start_Here;
+
+ protected Middle_PO is
+ entry Stop_1;
+ entry Stop_2;
+ end Middle_PO;
+
+ protected Final_PO is
+ entry Final_Stop;
+ end Final_PO;
+
+
+ protected body Start_Here is
+ entry AST_Waits_Here when Open is
+ begin
+ null;
+ end AST_Waits_Here;
+
+ entry Start_PO when True is
+ begin
+ Open := True;
+ Checkpoint.Got_Here (1);
+ requeue First_Stop;
+ end Start_PO;
+
+ -- make sure the AST has been accepted before continuing
+ entry First_Stop when AST_Waits_Here'Count = 0 is
+ begin
+ Checkpoint.Got_Here (2);
+ requeue Middle_PO.Stop_1;
+ end First_Stop;
+ end Start_Here;
+
+ protected body Middle_PO is
+ entry Stop_1 when True is
+ begin
+ Checkpoint.Got_Here (3);
+ requeue Stop_2;
+ end Stop_1;
+
+ entry Stop_2 when True is
+ begin
+ Checkpoint.Got_Here (4);
+ requeue Final_PO.Final_Stop;
+ end Stop_2;
+ end Middle_PO;
+
+ protected body Final_PO is
+ entry Final_Stop when True is
+ begin
+ Checkpoint.Got_Here (5);
+ end Final_Stop;
+ end Final_PO;
+
+
+ begin -- test encapsulation
+ select
+ Start_Here.AST_Waits_Here;
+ Checkpoint.Got_Here (6);
+ then abort
+ Start_Here.Start_PO;
+ delay 0.0; -- abort completion point
+ Checkpoint.Got_Here (7);
+ end select;
+
+ Check_The_Results: declare
+ Chk : constant Points_Array := Checkpoint.Results;
+ Expected : constant Points_Array := (1..6 => True,
+ 7 => False);
+ begin
+ for I in Checkpoint_ID loop
+ if Chk (I) /= Expected (I) then
+ Report.Failed ("checkpoint error" &
+ Checkpoint_ID'Image (I) &
+ " actual is " &
+ Boolean'Image (Chk(I)));
+ end if;
+ end loop;
+ end Check_The_Results;
+ exception
+ when others =>
+ Report.Failed ("unexpected exception");
+ end; -- test encapsulation
+
+ Report.Result;
+end C980002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c980003.a b/gcc/testsuite/ada/acats/tests/c9/c980003.a
new file mode 100644
index 000000000..dd69fc7ee
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c980003.a
@@ -0,0 +1,294 @@
+-- C980003.A
+--
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- TEST OBJECTIVE:
+-- Check that aborts are deferred during the execution of an
+-- Initialize procedure (as the last step of the default
+-- initialization of a controlled object), during the execution
+-- of a Finalize procedure (as part of the finalization of a
+-- controlled object), and during an assignment operation to an
+-- object with a controlled part.
+--
+-- TEST DESCRIPTION:
+-- A controlled type is created with Initialize, Adjust, and
+-- Finalize operations. These operations note in a protected
+-- object when the operation starts and completes. This change
+-- in state of the protected object will open the barrier for
+-- the entry in the protected object.
+-- The test contains declarations of objects of the controlled
+-- type. An asynchronous select is used to attempt to abort
+-- the operations on the controlled type. The asynchronous select
+-- makes use of the state change to the protected object to
+-- trigger the abort.
+--
+--
+-- CHANGE HISTORY:
+-- 11 Jan 96 SAIC Initial Release for 2.1
+-- 5 May 96 SAIC Incorporated Reviewer comments.
+-- 10 Oct 96 SAIC Addressed issue where assignment statement
+-- can be 2 assignment operations.
+--
+--!
+
+with Ada.Finalization;
+package C980003_0 is
+ Verbose : constant Boolean := False;
+
+ -- the following flag is set true whenever the
+ -- Initialize operation is called.
+ Init_Occurred : Boolean;
+
+ type Is_Controlled is new Ada.Finalization.Controlled with
+ record
+ Id : Integer;
+ end record;
+
+ procedure Initialize (Object : in out Is_Controlled);
+ procedure Finalize (Object : in out Is_Controlled);
+ procedure Adjust (Object : in out Is_Controlled);
+
+ type States is (Unknown,
+ Start_Init, Finished_Init,
+ Start_Adjust, Finished_Adjust,
+ Start_Final, Finished_Final);
+
+ protected State_Manager is
+ procedure Reset;
+ procedure Set (New_State : States);
+ function Current return States;
+ entry Wait_For_Change;
+ private
+ Current_State : States := Unknown;
+ Changed : Boolean := False;
+ end State_Manager;
+
+end C980003_0;
+
+
+with Report;
+with ImpDef;
+package body C980003_0 is
+ protected body State_Manager is
+ procedure Reset is
+ begin
+ Current_State := Unknown;
+ Changed := False;
+ end Reset;
+
+ procedure Set (New_State : States) is
+ begin
+ Changed := True;
+ Current_State := New_State;
+ end Set;
+
+ function Current return States is
+ begin
+ return Current_State;
+ end Current;
+
+ entry Wait_For_Change when Changed is
+ begin
+ Changed := False;
+ end Wait_For_Change;
+ end State_Manager;
+
+ procedure Initialize (Object : in out Is_Controlled) is
+ begin
+ if Verbose then
+ Report.Comment ("starting initialize");
+ end if;
+ State_Manager.Set (Start_Init);
+ if Verbose then
+ Report.Comment ("in initialize");
+ end if;
+ delay ImpDef.Switch_To_New_Task; -- tempting place for abort
+ State_Manager.Set (Finished_Init);
+ if Verbose then
+ Report.Comment ("finished initialize");
+ end if;
+ Init_Occurred := True;
+ end Initialize;
+
+ procedure Finalize (Object : in out Is_Controlled) is
+ begin
+ if Verbose then
+ Report.Comment ("starting finalize");
+ end if;
+ State_Manager.Set (Start_Final);
+ if Verbose then
+ Report.Comment ("in finalize");
+ end if;
+ delay ImpDef.Switch_To_New_Task; -- tempting place for abort
+ State_Manager.Set (Finished_Final);
+ if Verbose then
+ Report.Comment ("finished finalize");
+ end if;
+ end Finalize;
+
+ procedure Adjust (Object : in out Is_Controlled) is
+ begin
+ if Verbose then
+ Report.Comment ("starting adjust");
+ end if;
+ State_Manager.Set (Start_Adjust);
+ if Verbose then
+ Report.Comment ("in adjust");
+ end if;
+ delay ImpDef.Switch_To_New_Task; -- tempting place for abort
+ State_Manager.Set (Finished_Adjust);
+ if Verbose then
+ Report.Comment ("finished adjust");
+ end if;
+ end Adjust;
+end C980003_0;
+
+
+with Report;
+with ImpDef;
+with C980003_0; use C980003_0;
+with Ada.Unchecked_Deallocation;
+procedure C980003 is
+
+ procedure Check_State (Should_Be : States;
+ Msg : String) is
+ Cur : States := State_Manager.Current;
+ begin
+ if Cur /= Should_Be then
+ Report.Failed (Msg);
+ Report.Comment ("expected: " & States'Image (Should_Be) &
+ " found: " & States'Image (Cur));
+ elsif Verbose then
+ Report.Comment ("passed: " & Msg);
+ end if;
+ end Check_State;
+
+begin
+
+ Report.Test ("C980003", "Check that aborts are deferred during" &
+ " initialization, finalization, and assignment" &
+ " operations on controlled objects");
+
+ Check_State (Unknown, "initial condition");
+
+ -- check that initialization and finalization take place
+ Init_Occurred := False;
+ select
+ State_Manager.Wait_For_Change;
+ then abort
+ declare
+ My_Controlled_Obj : Is_Controlled;
+ begin
+ delay 0.0; -- abort completion point
+ Report.Failed ("state change did not occur");
+ end;
+ end select;
+ if not Init_Occurred then
+ Report.Failed ("Initialize did not complete");
+ end if;
+ Check_State (Finished_Final, "init/final for declared item");
+
+ -- check adjust
+ State_Manager.Reset;
+ declare
+ Source, Dest : Is_Controlled;
+ begin
+ Check_State (Finished_Init, "adjust initial state");
+ Source.Id := 3;
+ Dest.Id := 4;
+ State_Manager.Reset; -- so we will wait for change
+ select
+ State_Manager.Wait_For_Change;
+ then abort
+ Dest := Source;
+ end select;
+
+ -- there are two implementation methods for the
+ -- assignment statement:
+ -- 1. no temporary was used in the assignment statement
+ -- thus the entire
+ -- assignment statement is abort deferred.
+ -- 2. a temporary was used in the assignment statement so
+ -- there are two assignment operations. An abort may
+ -- occur between the assignment operations
+ -- Various optimizations are allowed by 7.6 that can affect
+ -- how many times Adjust and Finalize are called.
+ -- Depending upon the implementation, the state can be either
+ -- Finished_Adjust or Finished_Finalize. If it is any other
+ -- state then the abort took place at the wrong time.
+
+ case State_Manager.Current is
+ when Finished_Adjust =>
+ if Verbose then
+ Report.Comment ("assignment aborted after adjust");
+ end if;
+ when Finished_Final =>
+ if Verbose then
+ Report.Comment ("assignment aborted after finalize");
+ end if;
+ when Start_Adjust =>
+ Report.Failed ("assignment aborted in adjust");
+ when Start_Final =>
+ Report.Failed ("assignment aborted in finalize");
+ when Start_Init =>
+ Report.Failed ("assignment aborted in initialize");
+ when Finished_Init =>
+ Report.Failed ("assignment aborted after initialize");
+ when Unknown =>
+ Report.Failed ("assignment aborted in unknown state");
+ end case;
+
+
+ if Dest.Id /= 3 then
+ if Verbose then
+ Report.Comment ("assignment not performed");
+ end if;
+ end if;
+ end;
+
+
+ -- check dynamically allocated objects
+ State_Manager.Reset;
+ declare
+ type Pointer_Type is access Is_Controlled;
+ procedure Free is new Ada.Unchecked_Deallocation (
+ Is_Controlled, Pointer_Type);
+ Ptr : Pointer_Type;
+ begin
+ -- make sure initialize is done when object is allocated
+ Ptr := new Is_Controlled;
+ Check_State (Finished_Init, "init when item allocated");
+ -- now try aborting the finalize
+ State_Manager.Reset;
+ select
+ State_Manager.Wait_For_Change;
+ then abort
+ Free (Ptr);
+ end select;
+ Check_State (Finished_Final, "finalization in dealloc");
+ end;
+
+ Report.Result;
+
+end C980003;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c99004a.ada b/gcc/testsuite/ada/acats/tests/c9/c99004a.ada
new file mode 100644
index 000000000..8774314d5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c99004a.ada
@@ -0,0 +1,166 @@
+-- C99004A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT THE PREFIX OF 'TERMINATED AND 'CALLABLE CAN BE A
+-- FUNCTION CALL RETURNING AN OBJECT HAVING A TASK TYPE.
+
+-- NOTE: SEE TEST C38202A FOR CHECKS INVOLVING PREFIXES WHICH ARE
+-- ACCESS TYPES DENOTING TASK TYPES OR WHICH ARE FUNCTIONS
+-- RETURNING ACCESS TYPES DENOTING TASK TYPES.
+
+-- HISTORY:
+-- RJW 09/16/86 CREATED ORIGINAL TEST.
+-- DHH 10/15/87 CORRECTED HEADER COMMENTS.
+
+with Impdef;
+WITH REPORT; USE REPORT;
+PROCEDURE C99004A IS
+
+ TYPE ENUM IS (A, B, C, D);
+
+ EARRAY : ARRAY (ENUM) OF STRING (1 .. 17) :=
+ (A => "BEFORE ACTIVATION",
+ B => "DURING ACTIVATION",
+ C => "DURING EXECUTION ",
+ D => "AFTER TERMINATION" );
+
+ FUNCTION CHECK (S : STRING; CALL, B1, TERM, B2 : BOOLEAN;
+ E : ENUM) RETURN BOOLEAN IS
+ BEGIN
+ IF CALL /= B1 THEN
+ FAILED ( "INCORRECT VALUE FOR " & S & "'CALLABLE " &
+ EARRAY (E) & " OF TASK" );
+ END IF;
+
+ IF TERM /= B2 THEN
+ FAILED ( "INCORRECT VALUE FOR " & S & "'TERMINATED " &
+ EARRAY (E) & " OF TASK" );
+ END IF;
+
+ RETURN IDENT_BOOL (TRUE);
+ END CHECK;
+
+
+BEGIN
+ TEST ( "C99004A", "CHECK THAT THE PREFIX OF 'TERMINATED AND " &
+ "'CALLABLE CAN BE A FUNCTION CALL RETURNING " &
+ "AN OBJECT HAVING A TASK TYPE" );
+
+ DECLARE
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ PACKAGE PKG1 IS
+ T1 : TT;
+ END PKG1;
+
+ FUNCTION F RETURN TT IS
+ BEGIN
+ RETURN PKG1.T1;
+ END F;
+
+ PACKAGE PKG2 IS
+ A1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE,
+ F'TERMINATED, FALSE, A);
+ END PKG2;
+
+ TASK MAIN_TASK IS
+ ENTRY E (INTEGER RANGE 1 .. 2);
+ END MAIN_TASK;
+
+ TASK BODY TT IS
+ B1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE,
+ F'TERMINATED, FALSE, B);
+ C1 : BOOLEAN;
+ BEGIN
+ C1 := CHECK ("F", F'CALLABLE, TRUE,
+ F'TERMINATED, FALSE, C);
+ MAIN_TASK.E (1);
+ MAIN_TASK.E (2);
+ END TT;
+
+ PACKAGE BODY PKG1 IS
+ BEGIN
+ NULL;
+ END;
+
+ TASK BODY MAIN_TASK IS
+ D1 : BOOLEAN;
+ BEGIN
+ ACCEPT E (1);
+ ABORT PKG1.T1;
+ DELAY 5.0 * Impdef.One_Long_Second;
+ D1 := CHECK ("F", F'CALLABLE, FALSE,
+ F'TERMINATED, TRUE, D);
+ END MAIN_TASK;
+
+ BEGIN
+ NULL;
+ END;
+
+ DECLARE
+
+ TASK TYPE TT IS
+ ENTRY E;
+ END TT;
+
+ T2 : TT;
+
+ A2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE,
+ T2'TERMINATED, FALSE, A);
+
+ TASK MAIN_TASK IS
+ ENTRY E (INTEGER RANGE 1 .. 2);
+ END MAIN_TASK;
+
+ TASK BODY TT IS
+ B2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE,
+ T2'TERMINATED, FALSE, B);
+ C2 : BOOLEAN;
+ BEGIN
+ C2 := CHECK ("T2", T2'CALLABLE, TRUE,
+ T2'TERMINATED, FALSE, C);
+ MAIN_TASK.E (1);
+ MAIN_TASK.E (2);
+ END TT;
+
+ TASK BODY MAIN_TASK IS
+ D2 : BOOLEAN;
+ BEGIN
+ ACCEPT E (1);
+ ABORT T2;
+ DELAY 5.0 * Impdef.One_Long_Second;
+ D2 := CHECK ("T2", T2'CALLABLE, FALSE,
+ T2'TERMINATED, TRUE, D);
+ END MAIN_TASK;
+
+ BEGIN
+ NULL;
+ END;
+
+ RESULT;
+END C99004A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c99005a.ada b/gcc/testsuite/ada/acats/tests/c9/c99005a.ada
new file mode 100644
index 000000000..f3bcbaa6e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c99005a.ada
@@ -0,0 +1,183 @@
+-- C99005A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT THE ATTRIBUTE 'COUNT RETURNS THE CORRECT VALUE.
+
+-- HISTORY:
+-- DHH 03/24/88 CREATED ORIGINAL TEST.
+
+with Impdef;
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C99005A IS
+
+BEGIN
+
+ TEST("C99005A", "CHECK THAT THE ATTRIBUTE 'COUNT RETURNS THE " &
+ "CORRECT VALUE");
+
+ DECLARE
+ TASK A IS
+ END A;
+
+ TASK B IS
+ END B;
+
+ TASK C IS
+ END C;
+
+ TASK D IS
+ END D;
+
+ TASK E IS
+ END E;
+
+ TASK F IS
+ END F;
+
+ TASK G IS
+ END G;
+
+ TASK H IS
+ END H;
+
+ TASK I IS
+ END I;
+
+ TASK J IS
+ END J;
+
+ TASK T IS
+ ENTRY WAIT;
+ END T;
+
+ TASK CHOICE IS
+ ENTRY RETURN_CALL;
+ ENTRY E2;
+ ENTRY E1;
+ END CHOICE;
+
+ TASK BODY A IS
+ BEGIN
+ CHOICE.E1;
+ END A;
+
+ TASK BODY B IS
+ BEGIN
+ CHOICE.E1;
+ END B;
+
+ TASK BODY C IS
+ BEGIN
+ CHOICE.E1;
+ END C;
+
+ TASK BODY D IS
+ BEGIN
+ CHOICE.E1;
+ END D;
+
+ TASK BODY E IS
+ BEGIN
+ CHOICE.E1;
+ END E;
+
+ TASK BODY F IS
+ BEGIN
+ CHOICE.E2;
+ END F;
+
+ TASK BODY G IS
+ BEGIN
+ CHOICE.E2;
+ END G;
+
+ TASK BODY H IS
+ BEGIN
+ CHOICE.E2;
+ END H;
+
+ TASK BODY I IS
+ BEGIN
+ CHOICE.E2;
+ END I;
+
+ TASK BODY J IS
+ BEGIN
+ CHOICE.E2;
+ END J;
+
+ TASK BODY T IS
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT WAIT DO
+ DELAY 1.0 * Impdef.One_Second;
+ END WAIT;
+ CHOICE.RETURN_CALL;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END T;
+
+ TASK BODY CHOICE IS
+ BEGIN
+ WHILE E1'COUNT + E2'COUNT < 10 LOOP
+ T.WAIT;
+ ACCEPT RETURN_CALL;
+ END LOOP;
+
+ FOR I IN REVERSE 1 ..10 LOOP
+ SELECT
+ ACCEPT E2 DO
+ IF (E2'COUNT + E1'COUNT + 1) /= I THEN
+ FAILED("'COUNT NOT RETURNING " &
+ "CORRECT VALUE FOR LOOP" &
+ INTEGER'IMAGE(I) & "VALUE " &
+ INTEGER'IMAGE((E2'COUNT
+ + E1'COUNT + 1)));
+ END IF;
+ END E2;
+ OR
+ ACCEPT E1 DO
+ IF (E2'COUNT + E1'COUNT + 1) /= I THEN
+ FAILED("'COUNT NOT RETURNING " &
+ "CORRECT VALUE FOR LOOP" &
+ INTEGER'IMAGE(I) & "VALUE " &
+ INTEGER'IMAGE((E2'COUNT
+ + E1'COUNT + 1)));
+ END IF;
+ END E1;
+ END SELECT;
+ END LOOP;
+ END CHOICE;
+
+ BEGIN
+ NULL;
+ END;
+
+ RESULT;
+END C99005A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada
new file mode 100644
index 000000000..e8d7706cc
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada
@@ -0,0 +1,105 @@
+-- C9A003A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT ABORTING A TERMINATED TASK DOES NOT CAUSE EXCEPTIONS.
+
+
+-- RM 5/21/82
+-- SPS 11/21/82
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X
+
+with Impdef;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C9A003A IS
+
+ -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST )
+
+BEGIN
+
+
+ -------------------------------------------------------------------
+
+
+ TEST ("C9A003A", "CHECK THAT ABORTING A TERMINATED TASK" &
+ " DOES NOT CAUSE EXCEPTIONS" );
+
+
+ DECLARE
+
+
+ TASK TYPE T_TYPE IS
+
+
+ ENTRY E ;
+
+ END T_TYPE ;
+
+
+ T_OBJECT1 : T_TYPE ;
+
+
+ TASK BODY T_TYPE IS
+ BUSY : BOOLEAN := FALSE ;
+ BEGIN
+
+ NULL;
+
+ END T_TYPE ;
+
+
+ BEGIN
+
+
+ IF NOT T_OBJECT1'TERMINATED THEN
+ DELAY 20.0 * Impdef.One_Second;
+ END IF;
+
+ IF NOT T_OBJECT1'TERMINATED THEN
+ COMMENT( "TASK NOT YET TERMINATED (AFTER 20 S.)" );
+ END IF;
+
+
+ BEGIN
+ ABORT T_OBJECT1 ;
+ EXCEPTION
+
+ WHEN OTHERS =>
+ FAILED( "EXCEPTION RAISED (WHEN ABORTING A" &
+ " TERMINATED TASK)" );
+
+ END ;
+
+
+ END ;
+
+
+ -------------------------------------------------------------------
+
+
+
+ RESULT;
+
+
+END C9A003A ;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada
new file mode 100644
index 000000000..124724379
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada
@@ -0,0 +1,108 @@
+-- C9A004A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT IF A TASK IS ABORTED BEFORE BEING ACTIVATED, THE TASK IS
+-- TERMINATED.
+
+
+-- RM 5/21/82
+-- SPS 11/21/82
+-- JBG 6/3/85
+-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X
+
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C9A004A IS
+
+BEGIN
+
+
+ -------------------------------------------------------------------
+
+
+ TEST ("C9A004A", "CHECK THAT IF A TASK IS ABORTED" &
+ " BEFORE BEING ACTIVATED," &
+ " THE TASK IS TERMINATED" );
+
+
+ DECLARE
+
+
+ TASK TYPE T_TYPE IS
+
+
+ ENTRY E ;
+
+ END T_TYPE ;
+
+
+ T_OBJECT1 : T_TYPE ;
+
+
+ TASK BODY T_TYPE IS
+ BUSY : BOOLEAN := FALSE ;
+ BEGIN
+
+ NULL;
+
+ END T_TYPE ;
+
+
+ PACKAGE P IS
+ X : INTEGER := 0 ;
+ END P ;
+
+
+ PACKAGE BODY P IS
+ BEGIN
+
+ IF T_OBJECT1'TERMINATED OR
+ NOT T_OBJECT1'CALLABLE
+ THEN
+ FAILED( "WRONG VALUES FOR ATTRIBUTES" );
+ END IF;
+
+ ABORT T_OBJECT1 ; -- ELABORATED BUT NOT YET ACTIVATED.
+
+ END P ;
+
+
+ BEGIN
+
+
+ IF NOT T_OBJECT1'TERMINATED THEN
+ FAILED( "ABORTED (BEFORE ACTIVATION) TASK" &
+ " NOT TERMINATED" );
+ END IF;
+
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED");
+
+ END;
+
+ RESULT;
+
+END C9A004A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada
new file mode 100644
index 000000000..9339930a5
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada
@@ -0,0 +1,293 @@
+-- C9A007A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK MAY ABORT A TASK IT DEPENDS ON.
+
+
+-- RM 5/26/82
+-- RM 7/02/82
+-- SPS 11/21/82
+-- JBG 2/27/84
+-- JBG 3/8/84
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+-- EDS 08/04/98 ENSURE THAT ABORTED TASKS HAVE TIME TO EFFECT THEIR ABORTIONS.
+
+WITH IMPDEF;
+WITH REPORT; USE REPORT;
+WITH SYSTEM; USE SYSTEM;
+PROCEDURE C9A007A IS
+
+ TASK_NOT_ABORTED : BOOLEAN := FALSE;
+ TEST_VALID : BOOLEAN := TRUE ;
+
+BEGIN
+
+
+ -------------------------------------------------------------------
+
+
+ TEST ( "C9A007A" , "CHECK THAT A TASK MAY ABORT A TASK" &
+ " IT DEPENDS ON" );
+
+
+ DECLARE
+
+
+ TASK REGISTER IS
+
+
+ ENTRY BIRTHS_AND_DEATHS;
+
+ ENTRY SYNC1;
+ ENTRY SYNC2;
+
+
+ END REGISTER;
+
+
+ TASK BODY REGISTER IS
+
+
+ TASK TYPE SECONDARY IS
+
+
+ ENTRY WAIT_INDEFINITELY;
+
+ END SECONDARY;
+
+
+ TASK TYPE T_TYPE1 IS
+
+
+ ENTRY E;
+
+ END T_TYPE1;
+
+
+ TASK TYPE T_TYPE2 IS
+
+
+ ENTRY E;
+
+ END T_TYPE2;
+
+
+ T_OBJECT1 : T_TYPE1;
+ T_OBJECT2 : T_TYPE2;
+
+
+ TASK BODY SECONDARY IS
+ BEGIN
+ SYNC1;
+ ABORT T_OBJECT1;
+ DELAY 0.0;
+ TASK_NOT_ABORTED := TRUE;
+ END SECONDARY;
+
+
+ TASK BODY T_TYPE1 IS
+
+ TYPE ACCESS_TO_TASK IS ACCESS SECONDARY;
+
+ BEGIN
+
+
+ DECLARE
+ DEPENDENT_BY_ACCESS : ACCESS_TO_TASK :=
+ NEW SECONDARY ;
+ BEGIN
+ NULL;
+ END;
+
+
+ BIRTHS_AND_DEATHS;
+ -- DURING THIS SUSPENSION
+ -- MOST OF THE TASKS
+ -- ARE ABORTED (FIRST
+ -- TASK #1 -- T_OBJECT1 --
+ -- THEN #2 ).
+
+
+ TASK_NOT_ABORTED := TRUE;
+
+
+ END T_TYPE1;
+
+
+ TASK BODY T_TYPE2 IS
+
+ TASK INNER_TASK IS
+
+
+ ENTRY WAIT_INDEFINITELY;
+
+ END INNER_TASK;
+
+ TASK BODY INNER_TASK IS
+ BEGIN
+ SYNC2;
+ ABORT T_OBJECT2;
+ DELAY 0.0;
+ TASK_NOT_ABORTED := TRUE;
+ END INNER_TASK;
+
+ BEGIN
+
+
+ BIRTHS_AND_DEATHS;
+ -- DURING THIS SUSPENSION
+ -- MOST OF THE TASKS
+ -- ARE ABORTED (FIRST
+ -- TASK #1 -- T_OBJECT1 --
+ -- THEN #2 ).
+
+
+ TASK_NOT_ABORTED := TRUE;
+
+
+ END T_TYPE2;
+
+
+ BEGIN
+
+ DECLARE
+ OLD_COUNT : INTEGER := 0;
+ BEGIN
+
+
+ FOR I IN 1..5 LOOP
+ EXIT WHEN BIRTHS_AND_DEATHS'COUNT = 2;
+ DELAY 10.0 * Impdef.One_Second;
+ END LOOP;
+
+ OLD_COUNT := BIRTHS_AND_DEATHS'COUNT;
+
+ IF OLD_COUNT = 2 THEN
+
+ ACCEPT SYNC1; -- ALLOWING ABORT#1
+
+ DELAY IMPDEF.CLEAR_READY_QUEUE;
+
+ -- CHECK THAT #1 WAS ABORTED - 3 WAYS:
+
+ BEGIN
+ T_OBJECT1.E;
+ FAILED( "T_OBJECT1.E DID NOT RAISE" &
+ " TASKING_ERROR" );
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ NULL;
+
+ WHEN OTHERS =>
+ FAILED("OTHER EXCEPTION RAISED - 1");
+
+ END;
+
+ IF T_OBJECT1'CALLABLE THEN
+ FAILED( "T_OBJECT1'CALLABLE = TRUE" );
+ END IF;
+
+ IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1
+ THEN
+ FAILED( "TASK#1 NOT REMOVED FROM QUEUE" );
+ END IF;
+
+
+ OLD_COUNT := BIRTHS_AND_DEATHS'COUNT;
+
+
+ ACCEPT SYNC2; -- ALLOWING ABORT#2
+
+ DELAY IMPDEF.CLEAR_READY_QUEUE;
+
+ -- CHECK THAT #2 WAS ABORTED - 3 WAYS:
+
+ BEGIN
+ T_OBJECT2.E;
+ FAILED( "T_OBJECT2.E DID NOT RAISE" &
+ " TASKING_ERROR" );
+ EXCEPTION
+
+ WHEN TASKING_ERROR =>
+ NULL;
+
+ WHEN OTHERS =>
+ FAILED("OTHER EXCEPTION RAISED - 2");
+
+ END;
+
+ IF T_OBJECT2'CALLABLE THEN
+ FAILED( "T_OBJECT2'CALLABLE = TRUE" );
+ END IF;
+
+ IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1
+ THEN
+ FAILED( "TASK#2 NOT REMOVED FROM QUEUE" );
+ END IF;
+
+
+ IF BIRTHS_AND_DEATHS'COUNT /= 0 THEN
+ FAILED( "SOME TASKS STILL QUEUED" );
+ END IF;
+
+
+ ELSE
+
+ COMMENT( "LINEUP NOT COMPLETE (AFTER 50 S.)" );
+ TEST_VALID := FALSE;
+
+ END IF;
+
+
+ END;
+
+
+ WHILE BIRTHS_AND_DEATHS'COUNT > 0 LOOP
+ ACCEPT BIRTHS_AND_DEATHS;
+ END LOOP;
+
+
+ END REGISTER;
+
+
+ BEGIN
+
+ NULL;
+
+ END;
+
+
+ -------------------------------------------------------------------
+
+
+ IF TEST_VALID AND TASK_NOT_ABORTED THEN
+ FAILED( "SOME TASKS NOT ABORTED" );
+ END IF;
+
+
+ RESULT;
+
+
+END C9A007A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada
new file mode 100644
index 000000000..ba3b0845d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada
@@ -0,0 +1,117 @@
+-- C9A009A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- TEST ABORT DURING RENDEZVOUS
+
+-- CALLING TASK IN RENDEVOUS IS NAMED IN ABORT STATEMENT.
+
+-- JEAN-PIERRE ROSEN 09 MARCH 1984
+-- JBG 6/1/84
+-- JWC 6/28/85 RENAMED FROM C9A009D-B.ADA
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C9A009A IS
+
+BEGIN
+
+ TEST("C9A009A", "CALLING TASK IS ABORTED DIRECTLY");
+
+ DECLARE
+ -- T1 CALLS T2, WHICH ABORTS T1 WHILE IN RENDEVOUS
+
+ T2_CONTINUED : BOOLEAN := FALSE;
+
+ TASK CONTINUED IS
+ ENTRY GET (T2_CONTINUED : OUT BOOLEAN);
+ ENTRY PUT (T2_CONTINUED : IN BOOLEAN);
+ END CONTINUED;
+
+ TASK BODY CONTINUED IS
+ CONTINUED : BOOLEAN := FALSE;
+ BEGIN
+ LOOP
+ SELECT
+ ACCEPT GET (T2_CONTINUED : OUT BOOLEAN) DO
+ T2_CONTINUED := CONTINUED;
+ END GET;
+ OR
+ ACCEPT PUT (T2_CONTINUED : IN BOOLEAN) DO
+ CONTINUED := T2_CONTINUED;
+ END PUT;
+ OR
+ TERMINATE;
+ END SELECT;
+ END LOOP;
+ END CONTINUED;
+
+ BEGIN -- THIS BLOCK WILL MAKE SURE T2 IS TERMINATED, AND SO,
+ -- T2_CONTINUED IS ASSIGNED A VALUE IF T2 CONTINUES
+ -- EXECUTION CORRECTLY.
+
+ DECLARE
+
+ TASK T1;
+
+ TASK T2 IS
+ ENTRY E1;
+ END T2;
+
+ TASK BODY T1 IS
+ BEGIN
+ T2.E1;
+ FAILED ("T1 NOT ABORTED");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED IN T1");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION RAISED - T1");
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E1 DO
+ ABORT T1;
+ ABORT T1;
+ ABORT T1; -- WHY NOT?
+ IF T1'TERMINATED THEN
+ FAILED ("T1 PREMATURELY TERMINATED");
+ END IF;
+ END E1;
+ CONTINUED.PUT (T2_CONTINUED => TRUE);
+ END T2;
+ BEGIN
+ NULL;
+ END;
+ -- T2 NOW TERMINATED
+ CONTINUED.GET (T2_CONTINUED);
+ IF NOT T2_CONTINUED THEN
+ FAILED ("WHEN CALLER WAS ABORTED IN RENDEVOUS, CALLED " &
+ "TASK DID NOT CONTINUE");
+ END IF;
+ END;
+
+ RESULT;
+
+END C9A009A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada
new file mode 100644
index 000000000..89b7390b1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada
@@ -0,0 +1,95 @@
+-- C9A009C.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- TEST ABORT DURING RENDEZVOUS
+
+-- THE CALLING TASK IN THE RENDEVOUS IS DEPENDENT ON THE ABORTED TASK,
+-- SO THE DEPENDENT TASK IS INDIRECTLY ABORTED WHILE IN A RENDEVOUS;
+-- NEITHER THE CALLING TASK NOR ITS MASTER CAN BE TERMINATED WHILE THE
+-- RENDEVOUS CONTINUES.
+
+-- JEAN-PIERRE ROSEN 09 MARCH 1984
+-- JBG 6/1/84
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C9A009C IS
+
+BEGIN
+
+ TEST("C9A009C", "DEPENDENT TASK IN RENDEVOUS WHEN MASTER IS " &
+ "ABORTED");
+
+ DECLARE
+ -- T2 CONTAINS DEPENDENT TASK T3 WHICH CALLS T1.
+ -- T1 ABORTS T2 WHILE IN RENDEVOUS WITH T3.
+
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK BODY T1 IS
+
+ TASK T2;
+
+ TASK BODY T2 IS
+ TASK T3;
+ TASK BODY T3 IS
+ BEGIN
+ T1.E1;
+ FAILED ("T3 NOT ABORTED");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR IN T3");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION IN T3");
+ END;
+ BEGIN -- T3 ACTIVATED NOW
+ NULL;
+ END T2;
+
+ BEGIN -- T1
+ ACCEPT E1 DO
+ ABORT T2;
+ ABORT T2;
+ ABORT T2; -- WHY NOT?
+ IF T2'TERMINATED THEN
+ FAILED ("T2 TERMINATED PREMATURELY");
+ END IF;
+ END E1;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR IN T1 BECAUSE CALLING TASK "&
+ "WAS ABORTED");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION - T1");
+ END T1;
+
+ BEGIN
+ NULL;
+ END;
+
+ RESULT;
+
+END C9A009C;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada
new file mode 100644
index 000000000..e100a9f0c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada
@@ -0,0 +1,88 @@
+-- C9A009F.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK ABORTED DURING AN ENTRY CALL IS NOT TERMINATED
+-- BEFORE THE END OF THE RENDEZVOUS.
+
+-- JEAN-PIERRE ROSEN 16-MAR-1984
+-- JBG 6/1/84
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT,SYSTEM;
+USE REPORT,SYSTEM;
+PROCEDURE C9A009F IS
+
+
+ TASK BLOCKING IS
+ ENTRY START;
+ ENTRY STOP;
+ ENTRY RESTART;
+ ENTRY NO_CALL;
+ END BLOCKING;
+
+ TASK BODY BLOCKING IS
+ BEGIN
+ SELECT
+ ACCEPT STOP DO
+ ACCEPT START;
+ ACCEPT RESTART;
+ END;
+ OR TERMINATE;
+ END SELECT;
+ END;
+
+BEGIN
+
+ TEST("C9A009F", "ABORTED TASK NOT TERMINATED BEFORE END OF " &
+ "RENDEVOUS");
+
+ DECLARE -- T1 ABORTED WHILE IN RENDEVOUS WITH BLOCKING.
+
+ TASK T1 IS
+ END T1;
+ TASK BODY T1 IS
+ BEGIN
+ BLOCKING.STOP;
+ FAILED ("T1 NOT ABORTED");
+ END;
+
+ BEGIN
+ BLOCKING.START; -- ALLOWS T1 TO ENTER RENDEVOUS
+
+ ABORT T1;
+
+ IF T1'CALLABLE THEN
+ FAILED("T1 STILL CALLABLE - 1");
+ END IF;
+
+ IF T1'TERMINATED THEN -- T1 STILL IN RENDEVOUS
+ FAILED("T1 PREMATURELY TERMINATED - 1");
+ END IF;
+
+ BLOCKING.RESTART;
+ END;
+
+ RESULT;
+
+END C9A009F;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada
new file mode 100644
index 000000000..7dea8a4ba
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada
@@ -0,0 +1,95 @@
+-- C9A009G.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A MASTER ABORTED WITH SUBTASKS IN AN ENTRY CALL BECOMES
+-- COMPLETED, BUT NOT TERMINATED, BEFORE THE END OF THE RENDEZVOUS.
+
+-- JEAN-PIERRE ROSEN 16-MAR-1984
+-- JBG 6/1/84
+-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
+
+WITH REPORT,SYSTEM;
+USE REPORT,SYSTEM;
+PROCEDURE C9A009G IS
+
+
+ TASK BLOCKING IS
+ ENTRY START;
+ ENTRY STOP;
+ ENTRY RESTART;
+ ENTRY NO_CALL;
+ END BLOCKING;
+
+ TASK BODY BLOCKING IS
+ BEGIN
+ SELECT
+ ACCEPT STOP DO
+ ACCEPT START;
+ ACCEPT RESTART;
+ END;
+ OR TERMINATE;
+ END SELECT;
+ END;
+
+BEGIN
+
+ TEST("C9A009G", "MASTER COMPLETED BUT NOT TERMINATED");
+
+ DECLARE -- T1 ABORTED WHILE DEPENDENT TASK IN RENDEVOUS 9C?
+
+ TASK T1 IS
+ ENTRY LOCK;
+ END T1;
+
+ TASK BODY T1 IS
+ TASK T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ BLOCKING.STOP;
+ FAILED ("T2 NOT ABORTED");
+ END;
+ BEGIN
+ BLOCKING.NO_CALL; -- WILL DEADLOCK UNTIL ABORT
+ END T1;
+
+ BEGIN
+ BLOCKING.START;
+ ABORT T1;
+
+ IF T1'CALLABLE THEN
+ FAILED("T1 STILL CALLABLE - 2");
+ END IF;
+
+ IF T1'TERMINATED THEN -- T1'S DEPENDENT TASK, T2, STILL IN
+ -- RENDEVOUS
+ FAILED("T1 PREMATURELY TERMINATED - 2");
+ END IF;
+
+ BLOCKING.RESTART;
+ END;
+
+ RESULT;
+
+END C9A009G;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada
new file mode 100644
index 000000000..914fce187
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada
@@ -0,0 +1,77 @@
+-- C9A009H.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- CHECK THAT A TASK ABORTED DURING A RENDEVOUS IS NEITHER CALLABLE NOR
+-- TERMINATED BEFORE THE END OF THE RENDEVOUS.
+
+-- J.P ROSEN, ADA PROJECT, NYU
+-- JBG 6/1/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C9A009H IS
+BEGIN
+ TEST ("C9A009H", "TASK ABORTED IN RENDEVOUS IS NOT CALLABLE OR " &
+ "TERMINATED");
+
+ DECLARE
+
+ TASK T1 IS
+ ENTRY E1;
+ END T1;
+
+ TASK T2 IS
+ END T2;
+
+ TASK BODY T2 IS
+ BEGIN
+ T1.E1;
+ FAILED ("T2 NOT ABORTED");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR RAISED IN ABORTED TASK");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION RAISED");
+ END T2;
+
+ TASK BODY T1 IS
+ BEGIN
+ ACCEPT E1 DO
+ ABORT T2;
+ IF T2'CALLABLE THEN
+ FAILED ("T2 STILL CALLABLE");
+ END IF;
+
+ IF T2'TERMINATED THEN
+ FAILED ("T2 TERMINATED");
+ END IF;
+ END E1;
+ END T1;
+
+ BEGIN
+ NULL;
+ END;
+
+ RESULT;
+
+END C9A009H;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada
new file mode 100644
index 000000000..553b72d80
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada
@@ -0,0 +1,89 @@
+-- C9A010A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- TEST ABORT DURING RENDEZVOUS
+
+-- ABORTING AN ABNORMAL (NOT YET TERMINATED) TASK.
+
+-- JEAN-PIERRE ROSEN 09 MARCH 1984
+-- JBG 6/1/84
+-- JWC 6/28/85 RENAMED FROM C9A009E-B.ADA
+-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C9A010A IS
+
+BEGIN
+
+ TEST("C9A010A", "ABORTING AN ABNORMAL TASK");
+
+ DECLARE
+ -- T1 CALLS T2. WHILE IN RENDEVOUS, T2 ABORTS T1 AND WAITS FOR A
+ -- CALL FROM THE MAIN PROGRAM. WHEN THE CALL IS ACCEPTED, THE MAIN
+ -- PROGRAM AGAIN ABORTS T1, WHICH IS NOW ABNORMAL, SINCE T1 HAS NOT
+ -- YET COMPLETED ITS RENDEVOUS WITH T2.
+
+ TASK T1 IS
+ END T1;
+
+ TASK T2 IS
+ ENTRY E1;
+ ENTRY E2;
+ END T2;
+
+ TASK BODY T1 IS
+ BEGIN
+ T2.E1;
+ FAILED("T1 NOT ABORTED");
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ FAILED ("TASKING_ERROR IN T1");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION IN T1");
+ END T1;
+
+ TASK BODY T2 IS
+ BEGIN
+ ACCEPT E1 DO
+ ABORT T1;
+ ACCEPT E2; -- NOTE CALLER REMAINS IN RENDEVOUS
+ ACCEPT E2; -- UNTIL TWO ENTRY CALLS ACCEPTED
+ END E1;
+ END T2;
+ BEGIN
+ T2.E2; -- ONLY ACCEPTED AFTER T1 HAS BEEN ABORTED.
+ ABORT T1; -- T1 IS ABNORMAL BECAUSE IT IS STILL IN RENDEVOUS.
+ IF T1'CALLABLE THEN
+ FAILED ("T1 CALLABLE AFTER BEING ABORTED");
+ END IF;
+ IF T1'TERMINATED THEN
+ FAILED ("T1 TERMINATED ALTHOUGH IN RENDEVOUS");
+ END IF;
+ T2.E2; -- T1'S RENDEVOUS CAN NOW COMPLETE; T1 CAN TERMINATE.
+ END;
+
+ RESULT;
+
+END C9A010A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada
new file mode 100644
index 000000000..1d415b07b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada
@@ -0,0 +1,71 @@
+-- C9A011A.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT IF A CALLED TASK IS ABORTED WHILE IN RENDEZVOUS, THEN
+-- "TASKING_ERROR" IS RAISED IN THE CALLING TASK.
+
+-- HISTORY:
+-- DHH 03/28/88 CREATED ORIGINAL TEST.
+
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C9A011A IS
+
+ TASK TYPE CHOICE IS
+ ENTRY E1;
+ END CHOICE;
+
+ T : CHOICE;
+
+ TASK BODY CHOICE IS
+ X : INTEGER;
+ BEGIN
+ ACCEPT E1 DO
+ X := IDENT_INT(3);
+ IF EQUAL(X,X) THEN
+ ABORT CHOICE;
+ END IF;
+ END E1;
+ END CHOICE;
+
+BEGIN
+
+ TEST("C9A011A", "CHECK THAT IF A CALLED TASK IS ABORTED WHILE " &
+ "IN RENDEZVOUS, THEN ""TASKING_ERROR"" IS " &
+ "RAISED IN THE CALLING TASK");
+
+ T.E1;
+ FAILED("EXCEPTION NOT RAISED ON ABORT");
+
+ RESULT;
+
+EXCEPTION
+ WHEN TASKING_ERROR =>
+ RESULT;
+
+ WHEN OTHERS =>
+ FAILED("UNEXPECTED EXCEPTION RAISED ON ABORT");
+ RESULT;
+END C9A011A;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada b/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada
new file mode 100644
index 000000000..fe1ba1649
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada
@@ -0,0 +1,102 @@
+-- C9A011B.ADA
+
+-- Grant of Unlimited Rights
+--
+-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
+-- unlimited rights in the software and documentation contained herein.
+-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
+-- this public release, the Government intends to confer upon all
+-- recipients unlimited rights equal to those held by the Government.
+-- These rights include rights to use, duplicate, release or disclose the
+-- released technical data and computer software in whole or in part, in
+-- any manner and for any purpose whatsoever, and to have or permit others
+-- to do so.
+--
+-- DISCLAIMER
+--
+-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
+-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+-- PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- OBJECTIVE:
+-- CHECK THAT "TASKING_ERROR" IS RAISED BY A TIMED ENTRY CALL IF
+-- THE CALLED TASK IS ABORTED BEFORE THE DELAY EXPIRES BUT NOT
+-- WHEN THE CALL IS FIRST EXECUTED.
+
+-- HISTORY:
+-- DHH 06/14/88 CREATED ORIGINAL TEST.
+
+with Impdef;
+WITH SYSTEM; USE SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C9A011B IS
+
+ TASK TIMED_ENTRY IS
+ ENTRY WAIT_AROUND;
+ END TIMED_ENTRY;
+
+ TASK OWNER IS
+ ENTRY START;
+ ENTRY SELF_ABORT;
+ END OWNER;
+
+ TASK BODY TIMED_ENTRY IS
+ BEGIN
+ SELECT
+ OWNER.SELF_ABORT;
+ OR
+ DELAY 60.0 * Impdef.One_Second;
+ END SELECT;
+ FAILED("NO EXCEPTION RAISED");
+
+ ACCEPT WAIT_AROUND;
+ EXCEPTION
+ WHEN TASKING_ERROR =>
+ ACCEPT WAIT_AROUND;
+ WHEN OTHERS =>
+ FAILED("WRONG EXCEPTION RAISED");
+ ACCEPT WAIT_AROUND;
+ END TIMED_ENTRY;
+
+ TASK BODY OWNER IS
+ BEGIN
+ ACCEPT START DO
+ WHILE SELF_ABORT'COUNT = 0 LOOP
+ DELAY 1.0 * Impdef.One_Second;
+ END LOOP;
+ END START;
+
+ ABORT OWNER;
+
+ ACCEPT SELF_ABORT;
+
+ END OWNER;
+
+BEGIN
+
+ TEST("C9A011B", "CHECK THAT ""TASKING_ERROR"" IS RAISED BY A " &
+ "TIMED ENTRY CALL IF THE CALLED TASK IS " &
+ "ABORTED BEFORE THE DELAY EXPIRES BUT NOT " &
+ "WHEN THE CALL IS FIRST EXECUTED");
+
+ OWNER.START;
+ DELAY 5.0 * Impdef.One_Second;
+
+ IF TIMED_ENTRY'CALLABLE THEN
+ TIMED_ENTRY.WAIT_AROUND;
+ ELSE
+ FAILED("TASK ABORTED WHEN TASKING ERROR IS RAISED");
+ END IF;
+
+ RESULT;
+
+EXCEPTION
+ WHEN OTHERS =>
+ FAILED("EXCEPTION RAISED OUTSIDE OF TASK");
+ RESULT;
+
+END C9A011B;